| |
▼総裁 さん：
アップされたサンプルを見る限りＩＤの昇順に並んでいるようですので
こちらのほうが早いかも。
なお、新しく作るブックのシートの列幅等の書式は元シートを継承しています。
Sub Sample2()
Dim v As Variant
Dim newSh As Worksheet
Dim i As Long, k As Long
Dim w() As Variant
Dim oldID As Variant, newID As Variant
Application.ScreenUpdating = False
Sheets.Add before:=Sheets(1)
Set newSh = ActiveSheet
newSh.Cells.ClearContents
With Sheets("Sheet1")
v = .Range("A2", .Range("A" & .Rows.Count).End(xlUp).Offset(1, 3))
ReDim w(LBound(v, 1) To UBound(v, 1), 1 To 4)
For i = LBound(v, 1) To UBound(v, 1)
If i = LBound(v, 1) Then oldID = v(i, 1)
newID = v(i, 1)
If oldID <> newID Then
newSh.Cells.ClearContents
newSh.Range("A1:D1").Value = .Range("A1:D1").Value
newSh.Range("A2").Resize(k, 4).Value = w
newSh.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\ID" & oldID & ".xls"
ActiveWorkbook.Close
k = 0
ReDim w(LBound(v, 1) To UBound(v, 1), 1 To 4)
End If
k = k + 1
w(k, 1) = v(i, 1)
w(k, 2) = v(i, 2)
w(k, 3) = v(i, 3)
w(k, 4) = v(i, 4)
oldID = newID
Next
End With
Application.DisplayAlerts = False
newSh.Delete
Application.DisplayAlerts = True
Set newSh = Nothing
Application.ScreenUpdating = True
MsgBox "処理が終了しました。"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
