由于缺乏VBA优化，Excel 2013溢出
我希望将数据从统一表单（DATA）导出到多个关于条件的表单中。 我总共有13个标准，每个标准都必须在其专用表中输出。
我试图优化这个macros（这里只有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 如果你有任何想法，我读了我可以使用高级filter，但你猜我是新的VBA所以我听任何提示！
以下是您要求的高级筛选方法：
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的工作表。
UPDATE
根据标准模式可以更改的新信息，请改用此版本。 请注意，它假设工作表已经存在，并且工作表名称符合条件：
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
尝试使用数组来设置标准表：
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
这是有点不清楚，因为如果你遵循你已经发布的代码 – 它实际上只是复制和粘贴数据到同一张表…
是的，你应该使用自动filter，并使用一个特殊的select只获得可见的单元格。
如果你需要循环方法，你应该循环遍历工作表上的每一行（“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