用於VBA的排列陣列不起作用

Question

我想找到同一工作表中兩個不同列的不匹配。我正在使用動態數組來存儲這2列的所有數據。但我的代碼下面有一些錯誤，我無法修復它。

Sub Mismatch() 

Dim sht As Worksheet 
Dim i As Integer 
Dim j As Integer 
Dim k As Integer 
Dim last As Integer 
Dim BTID() As String 
Dim CMF() As String 

''find Mismatch 
Sheets("Authorizations Issued").Select 
Range("A1:BI1").Copy 
Sheets("Mismatch").Select 
Range("A1").Select 
ActiveSheet.Paste 

Sheets("Authorizations Issued").Select 
last = ActiveSheet.UsedRange.Rows.Count 

For i = 1 To last 
    Range("A2").Select 
    Sheets("Authorizations Issued").Select 
    Do While Selection.Value <> "Cust Bill To ID" 
     ActiveCell.Offset(0, 1).Select 
    Loop 
    If Selection.Value = "Cust Bill To ID" Then 
     ActiveCell.Offset(i, 0).Select 
     BTID(i) = Selection.Value 
    End If 
Next i 

For j = 1 To last 
    Range("A2").Select 
    Do While Selection.Value <> "SAP CMF#" 
     ActiveCell.Offset(0, 1).Select 
    Loop 
    If Selection.Value = "SAP CMF#" Then 
     ActiveCell.Offset(j, 0).Select 
     CMF(j) = Selection.Value 
    End If 
Next j 

Dim l As Integer 
l = 2 

For k = 3 To last 
    If BTID(k) <> CMF(k) Then 
     Range("$A$" & k & ":$BH$" & k).Copy 

     Sheets("Mismatch").Select 
     Range("$A$" & l).Select 
     ActiveSheet.Paste 
     l = l + 1 

    Else: l = l 

    End If 
    Next k 

Sheets("Mismatch").Select 
ActiveSheet.UsedRange.Select 
Selection.EntireColumn.EntireColumn.AutoFit 

End Sub 

這兩條線突出顯示。

BTID(i) = Selection.Value 
CMF(j) = Selection.Value 

Answer 1

使用REDIM暗淡您的陣列

Sub Mismatch() 


Dim sht As Worksheet 
Dim i As Integer 
Dim j As Integer 
Dim k As Integer 
Dim last As Integer 
Dim BTID() As String 
Dim CMF() As String 

''find Mismatch 
Sheets("Authorizations Issued").Select 
Range("A1:BI1").Copy 
Sheets("Mismatch").Select 
Range("A1").Select 
ActiveSheet.Paste 

Sheets("Authorizations Issued").Select 
last = ActiveSheet.UsedRange.Rows.Count 


For i = 1 To last 
    Range("A2").Select 
    Sheets("Authorizations Issued").Select 
    Do While Selection.Value <> "Cust Bill To ID" 
     ActiveCell.Offset(0, 1).Select 
    Loop 
    If Selection.Value = "Cust Bill To ID" Then 
     ActiveCell.Offset(i, 0).Select 
redim preserve BTID(i) 
     BTID(i) = Selection.Value 
    End If 
Next i 


For j = 1 To last 
    Range("A2").Select 
    Do While Selection.Value <> "SAP CMF#" 
     ActiveCell.Offset(0, 1).Select 
    Loop 
    If Selection.Value = "SAP CMF#" Then 
     ActiveCell.Offset(j, 0).Select 
redim preserve CMF(J) 
     CMF(j) = Selection.Value 
    End If 
Next j 

Dim l As Integer 
l = 2 

For k = 3 To last 
    If BTID(k) <> CMF(k) Then 
     Range("$A$" & k & ":$BH$" & k).Copy 
     Sheets("Mismatch").Select 
     Range("$A$" & l).Select 
     ActiveSheet.Paste 
     l = l + 1 
    Else: l = l 
    End If 
    Next k 
Sheets("Mismatch").Select 
ActiveSheet.UsedRange.Select 
Selection.EntireColumn.EntireColumn.AutoFit 
End Sub 

Answer 2

這應該做你想要什麼，如果我的理解如下：

1. 複製從授權表錯配的標題行
2. 通過並比較授權表中的「Cust Bill TO ID」和「SAP CMF＃」列之間的數據
3. 複製的行數據低於

見代碼不匹配表：

Option Explicit 

Sub Mismatch() 


    Dim AuthIssuedsheet As Worksheet 
    Set AuthIssuedsheet = ThisWorkbook.Sheets("Authorizations Issued") 

    Dim MismatchSheet As Worksheet 
    Set MismatchSheet = ThisWorkbook.Sheets("Mismatch") 

    'Copying the header of AuthIssuedsheet to MismatchSheet 
    AuthIssuedsheet.Range("A1:BI1").Copy MismatchSheet.Range("A1") 

    Dim AuthShtLastRow As Long 

    'Finding last row of used data in Authorizations Issued sheet 
    With AuthIssuedsheet 
     AuthShtLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
    End With 

    Dim AuthShtLastCol As Long 

    'Finding last row of used data in Authorizations Issued sheet 
    With AuthIssuedsheet 
     AuthShtLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 
    End With 



    Dim CustBillCol As Range 
    Dim SAPCMF As Range 
    Dim CustBillArray As Variant 
    Dim SAPCMFArray As Variant 
    Dim CustBill_SAPCMF_Array As Variant 

    With AuthIssuedsheet 

    'Finds the header column with text Cust Bill To IF 
    Set CustBillCol = .Range(.Cells(1, 1), .Cells(1, .Columns.Count)).Find(_ 
       What:="Cust Bill To ID", After:=AuthIssuedsheet.Range("A1"), _ 
       LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _ 
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 
    'Finds the header column with text SAP CMF# 
    Set SAPCMF = .Range(.Cells(1, 1), .Cells(1, .Columns.Count)).Find(_ 
       What:="SAP CMF#", After:=AuthIssuedsheet.Range("A1"), _ 
       LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _ 
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 

    CustBillArray = .Range(.Cells(2, CustBillCol.Column), .Cells(AuthShtLastRow, CustBillCol.Column)) 
    SAPCMFArray = .Range(.Cells(2, SAPCMF.Column), .Cells(AuthShtLastRow, SAPCMF.Column)) 

    End With 

    Dim ArrayPos As Long 
    Dim LastRowMismatch As Long 

    'deletes old data from Mismatch sheet before copying the mismatch data over 
    MismatchSheet.Range(MismatchSheet.Rows(2), MismatchSheet.Rows(Rows.Count)).ClearContents 

    'Looping through every value in the two arrays to check for mismatchs 
    For ArrayPos = 1 To UBound(CustBillArray) 

     If CustBillArray(ArrayPos, 1) <> SAPCMFArray(ArrayPos, 1) Then 

      'Finding last row of used data in Mismatch sheet 
      With MismatchSheet 
       LastRowMismatch = .Cells(.Rows.Count, "A").End(xlUp).Row 
      End With 
      'Copy the information acorss to mismatch sheet 
       AuthIssuedsheet.Range(AuthIssuedsheet.Cells(ArrayPos + 1, 1), _ 
             AuthIssuedsheet.Cells(ArrayPos + 1, AuthShtLastCol)).Copy _ 
        MismatchSheet.Range("" & "A" & LastRowMismatch + 1) 

     End If 


     'becasue you might be running through a large data set i just put a msgbox every 20% to 
     'let user know it will be a while 
     'Ideally you would have a Userform with progress for large data sets 

     If ((ArrayPos/UBound(CustBillArray)) * 100) = 20 Or _ 
      ((ArrayPos/UBound(CustBillArray)) * 100) = 40 Or _ 
      ((ArrayPos/UBound(CustBillArray)) * 100) = 60 Or _ 
       ((ArrayPos/UBound(CustBillArray)) * 100) = 80 Then 

      MsgBox "Currently on " & Fix((ArrayPos/UBound(CustBillArray)) * 100) & "%" 

     End If 



    Next ArrayPos 

    MismatchSheet.UsedRange.EntireColumn.AutoFit 

    MsgBox "Complete!" 

End Sub 

Answer 3

我不能讓你出來嘗試做什麼。這是我得到的： -

Sub Mismatch() 
    ' 07 Apr 2017 

    Dim WsAut As Worksheet, WsMis As Worksheet 
    Dim Last As Long        ' WsAut.LastRow 
    Dim C As Long         ' WsAut.Column 

    Set WsAut = Sheets("Authorizations Issued") 
    Set WsMis = Sheets("Mismatch") 

    With WsAut 
     Last = .UsedRange.Rows.Count 
     .Range("A1:BI1").Copy Destination:=WsMis.Cells(1, 1) 
'  consider this instead:- 
'  Last = .Cells(.Rows.Count, "A").End(xlUp).Row 

     'find Mismatch 
     For C = 2 To Last 
      If .Cells(2, C).Value = "Cust Bill To ID" Then 
    '   ActiveCell.Offset(i, 0).Select 
       BTID(i) = Selection.Value 
      End If 
     Next i 
    End With 
End Sub 

第一份工作是擺脫我們所有的選擇命令。使用VBA時，您的所有工作表都在內存中，並通過在內存中尋址它們來訪問它們：Workbook.Worksheet.Cells（Row，Column）。該工作手冊被認爲是主動的。如果您希望在另一個工作簿處於打開狀態時運行此代碼，則應該添加代碼以指定工作簿，也可能是包含代碼的工作簿。

然後，我想知道爲什麼使用UsedRange指定LastRow。如果您使用範圍A1：B10，那就是UsedRange。但是，如果您現在在C24中輸入一些內容並再次刪除它，UsedRange仍然是A1：C24。所以，如果可能的話，我建議將最後一行定義爲列中的非空白單元格。但是這要求在列結束之前不應該有空白單元格。

在新設置的幫助下，您的五行代碼複製範圍A1：BI2可以壓縮爲一行。但後來我遇到了麻煩，理解你想做什麼。看起來您正在尋找一個專欄標題「Cust Bill To ID」，但您使用Last表示您正在查看行。此外，看起來您打算在找到匹配項時選擇下一個單元格，但ActiveCell.Offset(i, 0).Select將選擇活動單元格下方i行的單元格，並且該單元格可以是小於Last的任何數字，並指定遠低於Last的單元格。

因此，我的循環For C = 2 to Last沒有做任何有用的事情。也許你可以用簡單的語言描述你的意圖，然後我們可以找到它的代碼。

Answer 4

聲明：我沒有測試的代碼，但這個概念應該是有效的：

Sub Mismatch() 

Dim authSht As Worksheet ' Renamed this variable 
Dim misSht As Worksheet ' Added a worksheet variable 
Dim i As Integer 
Dim k As Integer 
Dim last As Integer 
Dim BTID(1 To 1) As String ' We'll dim the arrays 1-based to avoid ninja arithmetics in the loop later 
Dim CMF(1 To 1) As String 
Dim rng1 As Range ' Added this variable 
Dim rng2 As Range ' Added this variable 

Set authSht = ThisWorkbook.Worksheets("Authorizations Issued") 
Set misSht = ThisWorkbook.Worksheets("Mismatch") 

''find Mismatch 
authSht.Range("A1:BI1").Copy 
misSht.Range("A1").Paste 

last = authSht.UsedRange.Rows.Count 

Set rng1 = authSht.Range("A2") 
Set rng2 = rng1 

For Each c In Range(rng1, authSht.Range(rng1.Row, authSht.Cells(1, Columns.Count).End(xlToLeft).Column)) 
    If c.Value = "Cust Bill To ID" Then Set rng1 = c 
    If c.Value = "SAP CMF#" Then Set rng2 = c 
Next c 

For i = 1 To last 
    BTID(i) = rng1.Offset(i, 0).Value 
    CMF(i) = rng2.Offset(i, 0).Value 

    If i < last Then ' If the loop will be executed at least 1 more time : 
     ReDim Preserve BTID(1 To i + 1) ' .. resize the arrays to make room for the next entry 
     ReDim Preserve CMF(1 To i + 1) 
    End If 
Next i 


Dim l As Integer 
l = 2 

For k = 3 To last 
    If BTID(k) <> CMF(k) Then 
     authSht.Range("$A$" & k & ":$BH$" & k).Copy 
     misSht.Range("$A$" & l).Paste 
     l = l + 1 
    Else 
     l = l 
    End If 
Next k 

misSht.UsedRange.EntireColumn.AutoFit 

End Sub 

簡而言之：

• 使用合格的範圍，以擺脫所有的各種Select使用
的
• 將兩個迴路（i和j）拉成一個，根據數據集應該節省20-40％的宏運行時間
• 陣列現在redimensioned

進一步優化：

• 所有搜索，添加，複製等可以在內存中，而不是在所述片材來完成。對於大規模的工作表來說，這將大大提高速度。特別是k循環 - 相反，添加到內存數組，完成後將數組推送到工作表。
• 首先定義「Cust Bill」和「SAP CMF」的列將消除查找正確範圍的需求。