セル A3 以降の名前列に基づいて、シート 1 のデータを複数のシートに分割しようとしています。私が直面している問題は、間にギャップがある場合、データを追跡できないことです。たとえば、名前は A3 から A100 で始まり、セル A10、A20、A30 の間は空で、プログラムは A3 から A9 までの値のみを追跡します。私にとってのもう1つの問題は、ヘッダーを指定することです。私が使用したいヘッダーはセルA2、B2、C2、D2から始まり、このプログラムはそのセルに値があるため、ヘッダーをA1、B1、C1、D1として表示します。これは私のコードです。
Private Sub CommandButton1_Click()
Dim ws As Worksheet, Rng As Range, cc
Dim temp As Worksheet, CostC As Range, u
Set ws = Sheets("Sheet1") 'where your original data. adjust to suit
Set Rng = ws.Range("a1").CurrentRegion.Resize(, 15)
Set CostC = ws.Range("a3", ws.Range("a" & Rows.Count).End(xlUp))
u = UNIQUE(CostC)
Application.ScreenUpdating = 0
For Each cc In u
With Rng
.AutoFilter field:=1, Criteria1:="=" & cc
On Error Resume Next
Set temp = Sheets(cc)
On Error GoTo 0
If Not temp Is Nothing Then
DoThis:
.SpecialCells(xlCellTypeVisible).Copy temp.Range("A1")
Else
Set temp = Sheets.Add
temp.Name = cc
GoTo DoThis
End If
.AutoFilter
End With
Set temp = Nothing
Next
Application.ScreenUpdating = 1
End Sub
Function UNIQUE(r As Range)
Dim a, v
If IsArray(r.Value) Then
a = r.Value
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For Each v In a
If Not IsEmpty(v) Then
If Not .exists(v) Then .Add v, Nothing
End If
Next
If .Count > 0 Then UNIQUE = .keys
End With
Erase a
Else
UNIQUE = r.Value
End If
End Function