arrays - VBA 将数组分配给范围并写入工作表返回全零

Question

我正在尝试将数组分配给 Excel 工作表中的一系列值。当我这样做时，即使使用 debug 数组并不全为零，它也会返回全零。奇怪的是 dat1 变量它确实正确写入单元格。尽管它与 dat2 一起是一个字符串数组。提前致谢。

Sub Comparor()
Dim dat1() As Variant
Dim dat2() As Variant

dat1() = Sheets("Data1").Range("E1:E10").Value2
dat2() = Sheets("Data2").Range("E1:E10").Value2

Dim iTemp As Integer
iTemp = CInt(UBound(dat1))
Dim NumMatches() As Integer
ReDim NumMatches(iTemp)


Dim iNum As Integer


Dim iCompareInner As Integer 'dat 2 cycler
Dim iCompareOuter As Integer 'dat 1 cycler

For iCompareOuter = 1 To UBound(dat1)
    For iCompareInner = 1 To UBound(dat2)
        If (dat1(iCompareOuter, 1) = dat2(iCompareInner, 1)) Then
            NumMatches(iCompareOuter) = NumMatches(iCompareOuter) + 1
        End If
    Next iCompareInner
Next iCompareOuter

Dim test22(10, 1) As Integer
For iNum = 1 To UBound(NumMatches)
    'Debug.Print NumMatches(iNum)
    test22(iNum, 1) = NumMatches(iNum)
    Debug.Print test22(iNum, 1)
Next iNum

Sheets("Info").Range("E1:E10").Value2 = dat1
Sheets("Info").Range("F1:F10").Value2 = test22
Sheets("Info").Range("G1:G10").Value2 = NumMatches

End Sub

Answer 1

匹配次数(字典、CountIf、数组(双循环))

• 所有三种解决方案都执行相同的操作。
• 将它们与一些重要的数据一起使用，例如100K 值上的 1K 个唯一值(例如，数组版本中的 100M 次迭代)将揭示每个代码的效率。
• 但这更多的是关于通常与(一列)范围一起使用的基于一的(一列)二维数组。
• 代码是基本的，即不会出现空白或错误​​值，并且每个范围至少有 2 个单元格
  (即 Data = rg.Value 对于一个单元格不起作用)。

Option Explicit


Sub ComparorDictionary()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read values (duplicates)
    Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
    Dim vData() As Variant: vData = vws.Range("E1:E10").Value
    Dim vrCount As Long: vrCount = UBound(vData, 1)
    
    ' Count matches using a dictionary.
    
    Dim vDict As Object: Set vDict = CreateObject("Scripting.Dictionary")
    vDict.CompareMode = vbTextCompare
    
    Dim vr As Long
    
    For vr = 1 To vrCount
        vDict(vData(vr, 1)) = vDict(vData(vr, 1)) + 1
    Next vr
    
    Erase vData ' values data is counted in the dictionary
    
    ' Read uniques (no duplicates).
    Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
    Dim uData() As Variant: uData = uws.Range("E1:E10").Value
    Dim urCount As Long: urCount = UBound(uData, 1)
    
    ' Write count.
    
    Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
    
    Dim ur As Long
    
    For ur = 1 To urCount
        If vDict.Exists(uData(ur, 1)) Then
            uMatches(ur, 1) = vDict(uData(ur, 1))
        End If
    Next ur
    
    Set vDict = Nothing ' data is in the unique arrays
    
    ' Write result.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
    
    dws.Range("E1").Resize(urCount).Value = uData
    dws.Range("F1").Resize(urCount).Value = uMatches
    
End Sub


Sub ComparorCountIf()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference values (duplicates). No array is needed.
    Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
    Dim vrg As Range: Set vrg = vws.Range("E1:E10")
    
    ' Read uniques (no duplicates).
    Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
    Dim uData() As Variant: uData = uws.Range("E1:E10").Value
    Dim urCount As Long: urCount = UBound(uData, 1)
    
    ' Count matches and write the count.
    
    Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
    
    Dim ur As Long
    
    For ur = 1 To urCount
        uMatches(ur, 1) = Application.CountIf(vrg, uData(ur, 1))
    Next ur
    
    ' Write result.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
    
    dws.Range("E1").Resize(urCount).Value = uData
    dws.Range("F1").Resize(urCount).Value = uMatches
    
End Sub


Sub ComparorArray()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read values (duplicates).
    Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
    Dim vData() As Variant: vData = vws.Range("E1:E10").Value
    Dim vrCount As Long: vrCount = UBound(vData, 1)
    
    ' Read uniques (no duplicates).
    Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
    Dim uData() As Variant: uData = uws.Range("E1:E10").Value
    Dim urCount As Long: urCount = UBound(uData, 1)
    
    ' Count matches and write the count.
    
    Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
    
    Dim vr As Long
    Dim ur As Long
    
    For ur = 1 To urCount
        For vr = 1 To vrCount
            If uData(ur, 1) = vData(vr, 1) Then
                uMatches(ur, 1) = uMatches(ur, 1) + 1
            End If
        Next vr
    Next ur
    
    Erase vData ' data is in the unique arrays
    
    ' Write result.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
    
    dws.Range("E1").Resize(urCount).Value = uData
    dws.Range("F1").Resize(urCount).Value = uMatches
    
End Sub