Excel VBA 宏过滤文件并将其复制到新工作簿上

Question

我对 VBA 编程非常陌生，并试图在 excel 中编写 VBA 代码 此代码将按 Criteria1:="=*001" 过滤我的文件并将所有唯一值复制到名为 AV 的新工作簿并保存。现在，我还想将Criteria1:="<>*001" 的所有值复制到名为 LC 的新工作簿并保存。

这是我在这个网站上找到的代码并尝试对其进行修改，但不知道如何将ELSE 用于Criteria1:="<>*001"。

Sub sort()
On Error Resume Next
Application.DisplayAlerts = False

Dim new_book As Workbook
Dim newsheet As Worksheet

With ThisWorkbook.Sheets("NRM_Homing_Upload")  'Replace the sheet name with the raw data sheet name

    Set newsheet = ThisWorkbook.Sheets("TempSheet")

        If newsheet Is Nothing Then
                Worksheets.Add.Name = "TempSheet"
            Else
                ThisWorkbook.Sheets("TempSheet").Delete
                Worksheets.Add.Name = "TempSheet"
        End If

            .Columns("H").Copy

                With ThisWorkbook.Sheets("cal")
                    .Range("A1").PasteSpecial (xlPasteAll)
                    .Columns("H").RemoveDuplicates Columns:=1, Header:=xlYes
                End With

                        For Each cell In ThisWorkbook.Sheets("TempSheet").Columns("a").Cells
                            i = i + 1
                                If i <> 1 And cell.Value <> "" Then
                                    .AutoFilterMode = False
                                    .Rows(1).AutoFilter field:=8, Criteria1:="=*001"
                                    Set new_book = Workbooks.Add
                                    .UsedRange.Copy
                                    new_book.Sheets(1).Range("a1").PasteSpecial (xlPasteAll)
                                    'new_book.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value & ".xlsx"
                                    new_book.SaveAs Filename:="C:\Desktop\excel\test\AV.xlsx"
                                    new_book.Sheets(1).UsedRange.Columns.AutoFit
                                    new_book.Save
                                    new_book.Close

                                End If
                        Next cell



                            ThisWorkbook.Sheets("TempSheet").Delete
End With

End Sub

感谢任何帮助。 谢谢

Answer 1

根据您的原始问题和 cmets，这里有几件事：

1. 无需为此创建临时表。您可以在制作新书后就地过滤列表并删除重复项
2. 您不需要遍历每个单元格。您可以简单地AutoFilter 数据范围
3. 由于您要制作两次新书，因此我将其放入其自己的子目录中（并调用了两次），其中包含要复制的工作簿和范围以及要保存的文件名的参数。
4. 使用On Error Resume Next 时请注意。您应该不惜一切代价避免它，但如果您绝对需要它（在某些情况下确实需要），请确保在您传递任何需要错误抑制的代码时使用On Error GoTo 0 重置错误标记。 *请注意，我重构的代码不包括抑制错误的需要。

这是重构后的代码：

Sub sort()

Application.DisplayAlerts = False

Rem Copy Data From NRM_Homing_Upload
With ThisWorkbook.Sheets("NRM_Homing_Upload")

    Dim lRow As Long
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    With .Range("A1:H" & lRow)

        .AutoFilter 8, "=*001"

        CopyToNewBook ThisWorkbook, ThisWorkbook.Sheets("NRM_Homing_Upload"), .SpecialCells(xlCellTypeVisible), "AV"

        .AutoFilter 1, "<>*001"

        CopyToNewBook ThisWorkbook, ThisWorkbook.Sheets("NRM_Homing_Upload"), .SpecialCells(xlCellTypeVisible), "LC"

    End With

    .AutoFilterMode = False

End With

End Sub

Sub CopyToNewBook(wb As Workbook, ws as Worksheet, rng As Range, sFile As String)

Dim new_book As Workbook
Set new_book = Workbooks.Add

wb.Sheets(ws.name).Range(rng.Address).Copy

With new_book

    With .Sheets(1)

        .Range("a1").PasteSpecial (xlPasteAll)
        .UsedRange.Columns.AutoFit
        .UsedRange.RemoveDuplicates Columns:=8, Header:=xlYes

    End With

    .SaveAs Filename:="C:\Desktop\excel\test\" & sFile & ".xlsx"
    .Close

End With

End Sub