0

セル 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
4

2 に答える 2

0

これは、最適化されていませんが、従うのが簡単なバージョンです。

Private Sub CommandButton1_Click()

Dim ws As Worksheet,  c As Range
Dim temp As Worksheet, CostC As Range, u

Set ws = Sheets("Sheet1") 

Set CostC = ws.Range(ws.Range("A3"), ws.Range("A" & Rows.Count).End(xlUp))

For each c in CostC.Cells

    u = trim(c.Value)
    If len(u) > 0 then

        Set temp = Nothing '<<EDIT
        On Error Resume Next
        Set temp = Sheets(u)
        On Error GoTo 0

        If temp is Nothing then
            Set temp = Sheets.Add()
            ws.Range("A2").Resize(1, 15).Copy temp.range("a1") 'copy headers
            temp.Name = u
        End If

        c.resize(1, 15).copy temp.cells(rows.count,1).end(xlup).offset(1,0)

     End if 'have name

Next c
End Sub
于 2013-10-24T06:31:00.207 に答える