数组 – 按一列过滤，但另存为另一列
下午好，
我是新使用数组，并与我的代码有点混淆。 目的是按照一列中的值过滤我的电子表格，然后按另一列中的值执行SaveAs。 自昨天以来，我一直在研究和改变这个代码，但不能实现。
Option Explicit Sub splitTEST() Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, i As Long, CountArr As Long Dim ws As Worksheet, MyArr As Variant, ArrName As Variant, vTitles As String, SvPath As String Set ws = Sheets("Sheet2") vTitles = "A1:Q1" vCol = Application.InputBox("What column to split data by? " & vbLf _ & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1) If vCol = 0 Then Exit Sub 'choose which column to filter, in this case 11 LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row Application.ScreenUpdating = False ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants)) ArrName = Application.WorksheetFunction.Transpose(ws.Range("L2:L" & Rows.Count).SpecialCells(xlCellTypeConstants)) 'column with name that determine SAVEAS name ws.Range("EE:EE").Clear ws.Range(vTitles).AutoFilter For Itm = 1 To UBound(MyArr) 'filter by, add new workbook, add two sheets ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) ws.Range("A1:A" & LR).EntireRow.Copy Workbooks.Add Range("A1").PasteSpecial xlPasteAll Cells.Columns.AutoFit MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1 Worksheets.Add Before:=Worksheets(Worksheets.Count) For i = 1 To UBound(ArrName) 'selecting the name to save the workbook ws.Range("A1:A" & LR).EntireRow.Copy CountArr = CountArr + Range("A" & Rows.Count).End(xlUp).Row - 1 ActiveWorkbook.SaveAs SvPath & ArrName & ".xlsx", 51 Next ActiveWorkbook.Close False Next Itm ws.AutoFilterMode = False MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!" Application.ScreenUpdating = True End Sub 'Jerry Beaucaire (4/22/2010) 我在这一行看到一个问题：
ActiveWorkbook.SaveAs SvPath & ArrName & ".xlsx", 51
你不要在ArrName上迭代。 我认为这应该是：
ActiveWorkbook.SaveAs SvPath & ArrName(i) & ".xlsx", 51
这至less是你的一个问题。