例文を使って繰り返し業務を時短

【マクロ・VBA】名前を付けて保存、かつ指定するエクセルファイルに追記保存する

エクセル、マクロ、VBAで名前を付けて保存する、そして別のエクセルファイルに追記して保存する VBA

名前を付けて保存/指定するエクセルファイルに追記保存

Sub 別ブックと追記ブックに保存()

'このファイル
Dim wb1 As Workbook
Set wb1 = ThisWorkbook   
Dim ws1 As Worksheet     
Set ws1 = ActiveSheet    

'②相手ファイルを開く
Dim fname As String
Dim wb2 As Workbook                               
Dim ws2 As Worksheet                               
'Dim LastRow2 As Long                              

MsgBox "「対象ファイル」選択"
ChDir ThisWorkbook.path
'ChDir "C:\Users\a\Desktop\VBA作業一式 & " \ "    
fname = Application.GetOpenFilename("Microsoft Excelブック,*.xls*")

If fname <> "False" Then
 Set wb2 = Workbooks.Open(fname)
 Set ws2 = wb2.Worksheets(1)                       
 LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row 
Else
 MsgBox "File未指定 "
End
End If

ws1.Range("A1").CurrentRegion.Copy           'ws1.Cells.copy

Worksheets.Add                               
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll
 
Application.CutCopyMode = False             
'Columns("A:E").Delete
Columns("A:AZ").AutoFit                    

'該当ブックに新規シート作成後、名前をつけて保存'----------------------------
Dim myPath As String
Dim bn As String
Dim nw As String
Dim LastRow1 As Long   'Dim LastRow1 As String
  
nw = VBA.Format(Now, "yyyymmdd " & "hh-mm")
bn = "【保存】〇〇_" & nw             'コピー先のシート名                                          
                                     
ActiveSheet.Name = bn                                    
Range("A2").Select
   
Workbooks.Add                              

'ファイル名を生成
Dim FileName As String

FileName = "C:\Users\a\Desktop\VBA作業一式\完了フォルダ" & "\" _
& "【集計】最終行に追加_" & nw & ".xlsx"

wb2.SaveAs FileName
'閉じる
Activebooks.Close
wb2.Close  '--------------------------
  
  
'②追記ブックへの保存処理
ws1.Activate
'ws1.Range("F32:BC" & LastRow1).Offset(1, 0).Copy  
ws1.Range("F32").CurrentRegion.Copy


'相手ファイル②
'Dim wb2 As Workbook
'Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\ファイル名入力,*.xls*")
'Dim ws2 As Worksheet
'Set ws2 = wb2.Worksheets(1) 
'相手ブックを開く
Workbooks.Open "C:\Users\a\Desktop\VBA作業一式\完了フォルダ\【集計】最終行に追加.xlsx"

'相手ブックの最終行(貼り付け先)
'Dim LastRow2 As Long
'LastLow2 = Worksheets(1).Cells(Rows.count, 2).End(xlUp).Row        
'LastLow2 = Worksheets("Sheet1").Range("C" & Rows.Count, 1).End(xlUp).Row   

'最終行下に貼り付け
Worksheets("sheet1").Range("A" & LastLow2 + 1).PasteSpecial xlPasteAll

'訂正を整える
'Columns("A:A").Delete
'ws1.Range("C:D,k:k,P:P,S:U,AC:AW").EntireColumn.Hidden = True
Columns("A:AZ").AutoFit


myPath = "C:\Users\a\Desktop\VBA作業一式\完了フォルダ" & "\"
bn = "【保存】〇〇_"                                                               
nw = VBA.Format(Now, "yyyymmdd " & "hh-mm")                                 
LastRow1 = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'LastRow1 = ws1.Cells(Rows.Count, 2).End(xlUp).Row 
'LastRow1 = ws1.Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Count



'相手ブックの保存(貼り付け側)
ActiveWorkbook.Save

Application.CutCopyMode = False
ws1.AutoFilterMode = False

'フィルタ解除
'If ws1.FilterMode Then
'ws1.ShowAllData
'End If

MsgBox "完了"
End Sub

・対象ファイルを選択:ChDir ThisWorkbook.Path ‘ChDir ThisWorkBook.Path & ” \ “”

コメント

タイトルとURLをコピーしました