Копировать строки с одного листа на другой в зависимости от условий, одновременно создавая уникальные имена листов.

Question

Я новичок в VBA и собрал нижеприведенный код, но мне кажется, что он излишне избыточен. Я разбил свой код VBA на 4 шага, которые я собрал, но я уверен, что есть более быстрый способ сделать это. По сути, у меня есть банковский отчет, который нужно скачать, и из него извлекается только соответствующая информация. В моем коде этот банковский отчет содержится в листе «Подробности». Этот отчет является переменным в зависимости от дня и транзакций, которые произошли. Вся информация в этом отчете основана на кодах банков BAI, которые находятся в столбце J. Шаг 1 в моем процессе - получить уникальный список всех кодов BAI за этот день и вставить эту информацию на новый лист. называется "ТЕКУЩИЙ БАЙ СПИСОК". Шаг 2 Я создаю несколько листов, названных в честь уникальных кодов BAI из шага 1. Шаг 3 предназначен для удаления не относящихся к делу листов. Например, некоторые из кодов BAI представляют собой сводные транзакции, в которых я не заинтересован и не буду с ними работать. Шаг 4 - захватить все соответствующие строки с информацией из основного листа «ДЕТАЛИ», которые соответствуют оставшимся полезным кодам BAI, и вставить эту информацию на соответствующий лист. Мне нужна помощь в следующем - на шаге 3 в идеале я хотел бы вместо того, чтобы перечислять все листы, которые должны остаться, чтобы сохранить список в диапазоне, может быть, и просто вставить имя списка. И в Шаге 4 я застреваю на Set Target = ActiveWorkbook.Worksheets(d.Value). Как я уже сказал, это кажется очень длинным и утомительным кодом. Любая помощь приветствуется.

    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "CURRENT BAI LIST"

    Worksheets("DETAIL").Activate
    Sheets("DETAIL").Range("J6:J1000").Select
    Selection.Copy
    Sheets("CURRENT BAI LIST").Select
    Sheets("CURRENT BAI LIST").Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$1000").RemoveDuplicates Columns:=1, Header:=xlYes
    Sheets("CURRENT BAI LIST").Range("A1").Select
    Sheets("CURRENT BAI LIST").Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
    '---END OF ADDS NEW SHEET FOR CURRENT BAI LIST AND COPIES THE DATA FROM "DETAIL" SHEET TO NEW SHEET


    'CREATES MULTIPLE SHEETS BASED ON THE UNIQUE BAI TRANSACTIONS
    Dim xRg As Excel.Range
    Dim wsH As Excel.Worksheet
    Dim wBk As Excel.Workbook
    Set wsH = ActiveWorkbook.Worksheets("CURRENT BAI LIST")
    Set wBk = ActiveWorkbook
    Dim L As Range
    Set L = Worksheets("CURRENT BAI LIST").UsedRange

    For Each xRg In L
        With wBk
            .Sheets.Add After:=.Sheets(.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xRg.Value
            If Err.Number = 1004 Then
              Debug.Print xRg.Value & " already used as a sheet name"
            End If
            On Error GoTo 0
        End With
    Next xRg
    '----END OF CREATES MULTIPLE SHEETS BASED ON THE UNIQUE BAI TRANSACTIONS


   'DELETES ALL NON-NECESSARY SHEETS SUCH AS SUMMARY BAI SHEETS AND OTHER
    Application.DisplayAlerts = False
    For Each wsH In Worksheets
        Select Case wsH.Name
            'Include sheet names to keep on next line (with comma between)
            Case "CASH SHEET", "BAI CODES", "DETAIL", "CURRENT BAI LIST", "164", "165", "187", "191", "195", "201", "255", "301", "354", "357", "455", "475", "491", "495", "501", "508", "555", "661", "856", "868"
                'Do nothing
            Case Else
                wsH.DELETE
        End Select
    Next wsH

    Application.DisplayAlerts = True
    '---END OF DELETES ALL NON-NECESSARY SHEETS SUCH AS SUMMARY BAI SHEETS AND OTHER

    'COPIES DATA FROM "DETAILS" SHEET TO ITS RESPECTIVE UNIQUE SHEET
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Condition As Worksheet


    Set Source = ActiveWorkbook.Worksheets("DETAIL")
    Set Condition = ActiveWorkbook.Worksheets("CURRENT BAI LIST")

    j = 2    'This will start copying data to Target sheet at row 2
      For Each d In L 'Condition.Range("A1:A86")
      Set Target = ActiveWorkbook.Worksheets(d.Value)
        For Each c In Source.Range("J1:J1000")
            If d = c Then
            Set Target = ActiveWorkbook.Worksheets(d.Value)
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
   '----END OF COPIES DATA FROM "DETAILS" SHEET TO ITS RESPECTIVE UNIQUE SHEET