Question

我们说我有一个包含三列的电子表格，其中A列具有重复值。行标题位于第3行。我希望为A列及其关联行中的每个唯一值拆分工作表，然后将它们复制到不同的工作簿 - 每个唯一值的一个工作簿来自A列

我根据我在网上找到的内容使用了以下代码，但这似乎非常有气质。有时它可以工作，但有时我会收到错误＆＃34;运行时错误＆＃39; 1004＆＃39;：没有找到细胞。＆＃34;我已在下面的代码中指出了一行注释，其中调试器指出错误是。有人可以帮我解决问题吗？

Option Explicit

Sub ParseItems()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

'Sheet with data in it
   Set ws = Sheets("input data")

'Path to save files into, remember the final \
    SvPath = "C:\My Work Documents\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:AT1"

'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'(THIS IS WHERE THE DEBUGGER STOPS) Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        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

        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51   'use for Excel 2007+
        ActiveWorkbook.Close False

        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    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

根据列值将Excel工作表拆分为多个工作簿

0 个答案: