Question

我有一个工作表，需要按列C的值拆分成新的工作表。有8个值，所以我需要8个工作表。每个值都有大约2-5000个对应的行，因此此脚本不是理想的，因为它逐行打印。

Sub SplitData()
    Const iCol = 3 ' names in second column (B)
    Const sRow = 2 ' data start in row 2

    Dim wshSource As Worksheet
    Dim wshTarget As Worksheet
    Dim i As Long
    Dim lRow As Long
    Dim lngTargetRow As Long

    Application.ScreenUpdating = False

    Set wshSource = Sheets(1)

    lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row

    For i = sRow To lRow

        If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
            Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshTarget.Name = wshSource.Cells(i, iCol).Value
            wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
            lngTargetRow = 2
        End If

        wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
        lngTargetRow = lngTargetRow + 1
    Next i

    Application.ScreenUpdating = True

End Sub

我将如何更改此值以将每个值块（C列）打印到每个工作表，而不是分别打印每个行（i）？我是否需要按列C值实现自动过滤并以这种方式进行循环？

Answer 1

正如您所指出的，尝试一下，过滤是这里最快的方法：

Option Explicit
Sub Test()

    Dim uniqueValues As Object
    Set uniqueValues = CreateObject("Scripting.Dictionary")

    Dim i As Long
    With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data

        'First let's store the unique values inside a dictionary
        For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
            If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
        Next i

        'Now let's loop through the unique values
        Dim Key As Variant
        For Each Key In uniqueValues.Keys
            .UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
            ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
        Next Key
    End With

End Sub

将价值块打印到新的工作表中？

1 个答案: