|
エラー処理は全くなので参考程度で。
Sub Sample()
Dim Dic, buf, Keys
Dim i As Long, j As Long, cnt As Long
Set Dic = CreateObject("Scripting.Dictionary")
cnt = Range("a65536").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To cnt
buf = WorksheetFunction.RoundUp(Cells(i, 1) / 1000, 0)
If Not Dic.Exists(buf) Then
Dic.Add buf, buf
End If
Next i
Keys = Dic.Keys
For i = 0 To Dic.Count - 1
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Keys(i)
Next i
With Worksheets(1)
For i = 0 To UBound(Keys)
For j = 2 To .Range("a1:a" & .Range("a65536").End(xlUp).Row).Rows.Count
If Left(.Cells(j, 1), 2) * 1 = Keys(i) Then
.Cells(j, 1).Copy Worksheets(i + 2).Range("a" & Worksheets(i + 2).Range("a65536").End(xlUp).Row + 1)
End If
Next
Next
End With
Application.ScreenUpdating = True
Set Dic = Nothing
End Sub
|
|