Excel VBA Macro, чтобы отфильтровать файл и скопировать его на новую книгу

Question

Я очень новичок в программировании VBA и пытаюсь написать код VBA в excel. Этот код будет фильтровать мой файл на 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