VBAデータ元から新規ブックに出力

質問

現在のブック内に出力されるとメモリの都合上時間がかかりすぎますそこで新規ブック１個に出力する構文を教えていただきたいのですが、宜しくお願いします。
Sub １１１１()
Dim c As Range
Dim i As Integer, LastRow As Long
Dim NewSheetName As String, MatchFlag As Boolean

Application.ScreenUpdating = False
NewSheetName = ""
With Sheets("データ元")
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
MatchFlag = False
If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then
NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月"
For i = 1 To Worksheets.Count
If Sheets(i).Name = NewSheetName Then
Sheets(i).Cells.ClearContents
MatchFlag = True
Exit For
End If
Next i
If MatchFlag = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = NewSheetName
End If
End If
LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value
Sheets(NewSheetName).Columns("A:F").EntireColumn.AutoFit
'↑A列からF列まで自動幅調整してます
Next
.Activate
End With
Application.ScreenUpdating = True
MsgBox "終了しました", vbInformation
End Sub

回答No.1

SI299792 · ベストアンサー

'
Option Explicit
'
Sub Macro2()
'
　　Dim c As Range
　　Dim i As Integer
　　Dim LastRow As Long
　　Dim NewSheetName As String
'
　　Application.ScreenUpdating = False
'
　　Workbooks.Add
'
　　With ThisWorkbook.Sheets("データ元")
　　For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
　　　　If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then
　　　　　　NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月"
　　　　　　If c.Row - 2 > Sheets.Count Then
　　　　　　　　Worksheets.Add after:=Worksheets(Worksheets.Count)
　　　　　　Else
　　　　　　　　Sheets(c.Row - 2).Select
　　　　　　End If
　　　　　　ActiveSheet.Name = NewSheetName
　　　　End If
　　　　LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row
　　　　Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value
　　　　Sheets(NewSheetName).Columns("A:F").EntireColumn.AutoFit
'↑A列からF列まで自動幅調整してます
　　Next
　　.Activate
　　End With
　　Application.ScreenUpdating = True
　　MsgBox "終了しました", vbInformation
End Sub

お礼

有難うございました、感謝です、助かりました。