匹配在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正如我在前面的评论中提到的，避免使用Excel保留字作为变量。与VB.Net不同的是，如果您像在VBA中那样声明变量，那么只会将最后一个变量声明为Range。其他3将被宣布为变体。 VB默认变量是类型Variant。 Variant类型变量可以保存任何类型的数据，从字符串，整数，长整数，日期到货币等。默认情况下，“变量”是“最慢”类型的变量。变体也应该避免，因为它们是造成可能的“类型不匹配错误”的原因。这并不是说我们不应该使用变体。只有在您不确定代码执行的可能性时才应该使用它们。

4）避免使用的话像.ActiveCell，Selection，Select，Activate等，他们是错误的主要原因。他们也减慢你的代码。

SUGGESTIONS

1）代替使用表（ “不管”）每一次，其存储在一个变量，然后使用该变量。将减少你的代码。

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

3）组任务一起。例如，如果您必须处理某个特定工作表的某些内容，请将它们放在一起。如果需要，阅读和修改更容易。

4）而不是硬编码的值，得到实际的范围。 Range("A2:A2500")是一个经典的例子。你会一直有数据到2500吗？如果它更少或更多呢？

5）End(xlDown)永远不会给你的最后一排，如果有一个空白单元格之间。为了让最后一排一列，比方说在“工作表Sheet1”，使用此

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

6）而是循环的，你可以使用WorksheetFunction CountIf()。尽可能避免循环，因为它们会减慢代码的速度。

7）使用合适的错误处理。

8）注释你的代码。知道特定的代码或部分正在做什么更容易。

CODE

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