名前を付けて保存/指定するエクセルファイルに追記保存
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 & ” \ “”
コメント