匹配在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