匹配 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 列将填充 A2:A2500 中的零。从弄乱断点开始，我发现问题出在我放置 * 的位置，但我不确定那里写的内容有什么问题。

谢谢

Answer 1

上面的代码有一些错误，我也有一些建议，最后是代码。

错误

1) Sheets.Add.Name = "Output" 如果已经有一个名为“输出”的工作表，则此行会给您一个错误。先删除工作表，然后再创建它。您一定想知道，如果工作表不存在，那么我该如何删除它？对于此类情况，您可以使用On Error Resume Next，在大多数情况下应避免使用。

2) 使用范围时，请始终指定您所指的工作表，否则 Excel 将始终假定您指的是“ActiveSheet”。当您意识到 Sub Convert_to_Numbers() 正在考虑 Output 工作表时，您希望操作发生在“输出”工作表中。

3) Dim Full, Selection, Code, SelectedCode As Range 正如我之前在 cmets 中提到的，避免使用 Excel 保留字作为变量。与 VB.Net 不同的是，如果您像在 VBA 中那样声明变量，那么只有最后一个变量将被声明为Range。其他 3 个将被声明为变体。 VB 默认变量为 Variant 类型。 Variant 类型变量可以保存任何类型的数据，从字符串、整数、长整数、日期、货币等。默认情况下，“Variants”是“最慢”类型的变量。还应避免变体，因为它们会导致可能的“类型不匹配错误”。并不是说我们永远不应该使用变体。仅当您不确定它们对代码执行的影响时才应使用它们。

4) 避免使用.ActiveCell、Selection、Select、Activate 等词。它们是导致错误的主要原因。它们还会减慢您的代码速度。

建议

1) 不是每次都使用 Sheets("WhatEver")，而是将其存储在一个变量中，然后使用该变量。将减少您的代码。

2) 缩进你的代码 :) 更容易阅读

3) 将任务分组在一起。例如，如果您必须处理与特定工作表有关的事情，那么请将其放在一起。如果需要，它更易于阅读和修改。

4) 获取实际范围，而不是硬编码您的值。 Range("A2:A2500") 是一个经典的例子。直到 2500 年，您是否总是有数据？少了还是多了怎么办？

5) 如果中间有空白单元格，End(xlDown) 永远不会给你最后一行。要获取列中的最后一行，例如“Sheet1”中的 A，请使用此

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