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

這裏根據你原來的問題和意見有幾件事情：

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