Соответствие двух списков данных в Excel VBA и экспорт в новый лист

Question

Я получаю файл excel ежемесячно и должен экспортировать его части в новый файл. У меня есть список номеров идентификаторов, и я пытаюсь сопоставить список номеров в выбранном списке с полным файлом, а затем экспортировать строки соответствующих данных на новый лист.

Sub Run_All_Macros() 
Application.ScreenUpdating = False 
Sheets.Add.Name = "Output" 
Call Convert_to_Numbers 
Call Highlight_Selected_Contractors 
End Sub 

'Original Spreadsheet is formatted incorrectly 
'Convert PSD Codes to Numbers 
Sub Convert_to_Numbers() 
Dim xCell As Range 
Range("A2:A2500").Select 
    For Each xCell In Selection 
    xCell.Value = CDec(xCell.Value) 
    Next xCell 
End Sub 


'Highlight Selected Contractors 
Sub Highlight_Selected_Contractors() 
Dim Full, Selection, Code, SelectedCode As Range 
Worksheets("Sheet1").Select 
'Set all cells in Column A Sheet 1 to Full 
Set Full = Worksheets("Sheet1").Range("A1", Range("A1").End(xlDown)) 
'Set all cells in Column A Sheet 2 to Selection 
Worksheets("Sheet2").Select 
Set Selection = Worksheets("Sheet2").Range("A1", Range("A1").End(xlDown)) 
'If the numbers match highlight the cell 
For Each Code In Full 
    For Each SelectedCode In Selection 
     If Code.Value = SelectedCode.Value Then 
     *** Code.Select 
     Selection.Copy 
     Sheets.Select ("Output") 
     ActiveSheet.Paste 
    End If 
Next SelectedCode 
Next Code 
End Sub 

После выполнения этого кода столбца A в 'Output' заполняется нулями A2: A2500. От беспорядка с точками останова я определил проблему, когда я разместил *, но я не уверен, что случилось с тем, что там написано.

Благодаря

Answer 1

Там несколько ошибок в коде выше, и у меня также есть несколько предложений, и, наконец, код.

ОШИБКИ

1)Sheets.Add.Name = "Output" Эта линия даст вам ошибку, если уже есть лист под названием "Ouput". Сначала удалите лист, а затем создайте его. Вы должны быть удивлены, что в случае, если лист отсутствует, то как я могу его удалить? Для таких сценариев вы можете использовать On Error Resume Next, которого следует избегать в большинстве случаев.

2) При работе с диапазонами всегда указывайте, на каком листе вы ссылаетесь на else. Excel всегда будет считать, что вы ссылаетесь на «ActiveSheet». Поскольку вы поняли, что Sub Convert_to_Numbers() принимал во внимание Output лист, тогда как вы хотите, чтобы операция выполнялась в листе «Выход».

3)Dim Full, Selection, Code, SelectedCode As Range Как уже упоминалось в моих комментариях, избегайте использования зарезервированных слов Excel в качестве переменных. Также, в отличие от VB.Net, если вы объявляете переменные, как в VBA, тогда только последняя переменная будет объявлена ​​как Range. Остальные 3 будут объявлены как варианты. VB по умолчанию изменяет значение типа Variant. Переменная типа Variant может содержать любые данные из строк, целых чисел, длинных целых чисел, дат, валюты и т. Д. По умолчанию «Варианты» являются «самыми медленными» типами переменных. Также следует избегать вариантов, поскольку они несут ответственность за возможное «Ошибки несоответствия типа». Дело не в том, что мы никогда не должны использовать Варианты. Они должны использоваться только в том случае, если вы не уверены в том, что они могут выполнять при выполнении кода.

4) Избегайте использования слов как .ActiveCell, Selection, Select, Activate и т.д. Они являются основной причиной ошибок. Также они замедляют ваш код.

SUGGESTIONS

1) Вместо того, чтобы с помощью Sheets ("все") каждый раз, сохранить его в переменной и затем использовать эту переменную. Сократит ваш код.

2) Отступ ваш код :) это гораздо легче читать

3) Групповые задачи вместе. Например, если вам нужно что-то делать с определенным листом, держите его вместе. Легче читать и изменять, если требуется.

4) Вместо жесткого кодирования ваших значений, получите фактические диапазоны. Range("A2:A2500") - классический пример. Будете ли вы иметь данные до 2500? Что, если это меньше или больше?

5)End(xlDown) никогда не даст вам последний ряд, если между ними есть пустая ячейка. Чтобы получить последнюю строку в столбце, скажем А в «Лист1», используйте этот

Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row` 

6) Вместо зацикливание, вы можете использовать WorksheetFunction CountIf(). Петли следует избегать как можно больше, поскольку они замедляют ваш код.

7) Используйте соответствующую обработку ошибок.

8) Прокомментируйте ваш код. Гораздо проще узнать, что делает конкретный код или раздел.

КОД

Option Explicit 

Sub Run_All_Macros() 
    Dim ws1I As Worksheet, ws2I As Worksheet, wsO As Worksheet 
    Dim ws1LRow As Long, ws2LRow As Long, wsOLr As Long 
    Dim xCell As Range, rFull As Range, rSelection As Range 
    Dim rCode As Range, rSelectedCode As Range 

    On Error GoTo Whoa '<~~ Error Handling 

    Application.ScreenUpdating = False 

    '~~> Creating the Output Sheet 
    Application.DisplayAlerts = False 
    On Error Resume Next 
    Sheets("Output").Delete 
    On Error GoTo 0 
    Sheets.Add.Name = "Output" 
    Application.DisplayAlerts = True 

    '~~> Working with 1st Input Sheet 
    Set ws1I = Sheets("Sheet1") 
    With ws1I 
     '~~> Get Last Row of Col A 
     ws1LRow = .Range("A" & Rows.Count).End(xlUp).Row 
     '~~> Set the range we want to work with 
     Set rFull = .Range("A1:A" & ws1LRow) 
     '~~> The following is not required unless you want to just format the sheet 
     '~~> This will have no impact on the comparision. If you want you can 
     '~~> uncomment it 
     'For Each xCell In .Range("A2:A" & ws1LRow) 
      'xCell.Value = CDec(xCell.Value) 
     'Next xCell 
    End With 

    '~~> Working with 2nd Input Sheet 
    Set ws2I = Sheets("Sheet2") '<~~ Input Sheet 2 
    ws2LRow = ws2I.Range("A" & Rows.Count).End(xlUp).Row 
    Set rSelection = ws2I.Range("A1:A" & ws2LRow) 

    '~~> Working with Output Sheet 
    Set wsO = Sheets("Output") 
    wsO.Range("A1") = "Common values" 
    wsOLr = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1 

    '~~> Comparison : If the numbers match copy them to Output Sheet 
    For Each rCode In rFull 
     If Application.WorksheetFunction.CountIf(rSelection, rCode.Value) > 0 Then 
      rCode.Copy wsO.Range("A" & wsOLr) 
      wsOLr = wsOLr + 1 
     End If 
    Next rCode 

    MsgBox "Done" 

LetsContinue: 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 

    Exit Sub 
Whoa: 
    MsgBox Err.Description 
    Resume LetsContinue 
End Sub 

Позвольте мне знать, если вы все еще получаете ошибки :)

HTH