Question

下午好，

我是使用数组的新手，并且与我的代码有点混淆。目的是按一列中的值过滤我的电子表格，然后按另一列中的值执行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)

Answer 1

我在这一行中看到了一个问题：

ActiveWorkbook.SaveAs SvPath & ArrName & ".xlsx", 51

你不要在ArrName上进行迭代。我认为应该是：

ActiveWorkbook.SaveAs SvPath & ArrName(i) & ".xlsx", 51

这至少是你的一个问题。

数组 - 按一列过滤，但另一列保存

1 个答案: