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

根据您原来的问题和评论，这里有一些事情：

无需为此创建临时表。您可以在适当的位置过滤列表，并在制作新书后删除重复项
您不需要遍历每个单元格。您只需AutoFilter数据范围
由于您正在制作新书两次，我将其放入其自己的子（并称之为两次），其中包含要复制的工作簿和范围的参数以及要保存的文件名。
使用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

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

1 个答案: