Question

我想将合并工作表（DATA）中的数据导出到有关条件的多个工作表中。我总共有13个标准，每个标准都必须在专用表格中导出。

我试图优化此宏（这里只有2个条件），因为它会滞后

Sub copy()

Application.ScreenUpdating = False

Dim i As Long
Dim j As Long

Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")

For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
    While Not IsEmpty(feuillePrincipale.Cells(i, 1))
        If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
        feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
        j = j + 1
        End If
    i = i + 1
    Wend
 End If

If sh.Name = "S02" Then
i = 2
j = 2
    While Not IsEmpty(feuillePrincipale.Cells(i, 1))
        If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
        feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
        j = j + 1
        End If
    i = i + 1
    Wend
End If

Next

Application.ScreenUpdating = True

End Sub

如果您有任何想法，我会看到我可以使用高级过滤器，但我猜你是VBA中的新手，所以我会听取任何提示！

Answer 1

尝试使用数组来设置标准表：

Dim shArray           As Variant
Dim shArrayString     As String
Dim feuillePrincipale As Excel.Worksheet
Dim i                 As Long
Dim j                 As Long

Set feuillePrincipale = ThisWorkbook.Sheets("DATA")

j = 1

'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required

'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
    shArrayString = shArrayString & shArray(i) & ""","""
Next    
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"

'//Start loop    
    With feuillePrincipale
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
                .Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
                j = j + 1
            End If
        Next
    End With

有点不清楚，因为如果你按照你发布的代码进行操作 - 实际上只是将数据复制并粘贴到同一张纸上......

Answer 2

以下是您要求的高级过滤方法：

Public Sub Christophe()

    Const FILTER_COLUMN = 11

    Dim i&, rCrit As Range, rData As Range, aShts

    aShts = ["SO"&row(1:13)]

    Set rData = Sheets("DATA").[a1].CurrentRegion
    Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
    rCrit(1) = rData(1, FILTER_COLUMN)

    For i = 1 To UBound(aShts)
        rCrit(2) = aShts(i, 1) & "*"
        rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
    Next

    rCrit.Clear

End Sub

执行时间应该是即时的。

注意：这假设您有13个条件，每个条件以“SO”开头，并且它们占据数据表的第11列。它还假设您已经在工作簿中有13张名为SO1 ... SO13的工作表。

<强>更新

根据标准模式可能发生变化的新信息，请尝试使用此版本。请注意，它假定工作表已存在且工作表名称符合条件：

Public Sub Christophe()

    Const FILTER_COLUMN = 11

    Dim i&, rCrit As Range, rData As Range, aShts

    aShts = Array("SO1", "SO2", "ADQ03", "LocS10")

    Set rData = Sheets("DATA").[a1].CurrentRegion
    Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
    rCrit(1) = rData(1, FILTER_COLUMN)

    For i = 0 To UBound(aShts)
        rCrit(2) = aShts(i) & "*"
        rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
    Next

    rCrit.Clear

End Sub

Answer 3

是的，您应该使用自动过滤器并使用特殊选择来仅获取可见单元格。

如果你想要循环方法，你应该遍历工作表上的每一行（“DATA”）并使用Select Case Statement来决定数据放在哪个工作表上。

通过循环遍历每张纸，您将添加会减慢它的循环。

Application.ScreenUpdating = False

Dim i As Long
Dim j As Long

Dim cel As Range

Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")

For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))

    Select Case Left(cel.offset(,10).value, 3)
        Case "S01"
            j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
            feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
        Case "S02"
            j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
            feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
        'Case ....  keep adding select statement till you get to the last condition
        Case Else
    End Select
Next cel

Application.ScreenUpdating = True

由于缺乏VBA优化，Excel 2013溢出

3 个答案: