使用VBA Excel在其他列中使用相同数字的列中的数字进行匹配 [英] Matching a number in a column with the same number in the other column using VBA Excel
问题描述
首先，我想对这个可怜的问题表示歉意，我希望这不会扰乱任何人。因为我不太会说英语来表达我的要求，所以请看看引用的链接，以便清楚地解释这个问题。
我正在尝试找到
基本上，我需要找到相同的借记卡和信用额度行，并将其与借记和信用在另一行中匹配。列C（行）表示匹配值。例如，行2中的借记值与行15中的信用值相匹配，反之亦然。列D（ID匹配）中的数字是用于指示首先找到的匹配数据的顺序的标号。这是我的代码，试图实现这个任务：
公开我长，j长，k长，Last_Row As Long
Public DC，Row_Data，ID_Match
Sub Quick_Match（）
T0 = Timer
k = 0
Last_Row = Cells（Rows.Count，A）。结束（xlUp）.Row
ReDim DC（1 To Last_Row - 1，1 To 2）
ReDim Row_Data（1 To Last_Row - 1，1 To 1）
ReDim ID_Match （1到Last_Row - 1，1到1）
DC =范围（A2：B& Last_Row）
对于i = 1 To Last_Row - 1
如果DC （i，1）< 然后
k = k + 1
对于j = 1 To Last_Row - 1
如果DC（i，1） DC（i，2）然后
如果DC（i，1）= DC（j，2）和DC（i，2）= DC（j，1）然后
调用Row_Label
退出对于
Else
Row_Data（i，1）=无匹配
如果
Else
如果i& j然后
如果DC（i，1）= DC（j，1）和DC（i，2）= DC（j，2）然后
调用Row_Label
退出
Else
Row_Data（i，1）=无匹配
End If
End If
End If
Next j
End If
如果Row_Data（i，1）=无匹配然后
k = k - 1
结束如果
下一个i
范围（C2：C& Last_Row）= Row_Data
范围（D2：D& Last_Row）= ID_Match
InputBox该程序的运行时是，运行时间 T0
End Sub
Sub Row_Label（）
Row_Data（i，1）= j + 1
ID_Match（i，1）= k
Row_Data （j，1）= i + 1
ID_Match（j，1）= k
DC（i，1）=
DC（i，2）=
DC（j，1）=
DC（j，2）=
End Sub
虽然是ab它的性能慢了，但是效果很好。它在我的机器上大约25秒钟内完成，用于处理10,000行数据（数据集文件可以下载
Sub DebitCreditCrossMatch（）
Dim dictKeys As Object，dictRows As Object
Dim DebitKey As String，CreditKey As String
Dim arrDebit，arrCredit，项目，键
Dim arrMatchRow（），arrMatchID（）
Dim ID As Long，rw As Long，x As Long，lastRow As Long
lastRow = Cells（Rows.count ，A）。End（xlUp）.Row
arrDebit = Range（A1，A& lastRow）.Value
arrCredit = Range（B1 B& lastRow）.Value
ReDim arrMatchID（lastRow - 2）
ReDim arrMatchRow（lastRow - 2）
设置dictKeys = CreateObject（Scripting字典）
对于x = 2 To lastRow
DebitKey = arrDebit（x，1）& ：& arrCredit（x，1）
CreditKey = arrCredit（x，1）& ：& arrDebit（x，1）
如果dictKeys.Exists（CreditKey）然后
设置dictRows = dictKeys（CreditKey）
items = dictRows.items
keys = dictRows。键
rw = CLng（items（0））
arrMatchRow（x - 2）= rw
arrMatchRow（rw - 2）= x
dictRows.Remove keys（0）
如果dictRows.count = 0 Then dictKeys.Remove CreditKey
ElseIf dictKeys.Exists（DebitKey）Then
Set dictRows = dictKeys（DebitKey）
dictRows 。添加x，x
Else
设置dictRows = CreateObject（Scripting.Dictionary）
dictRows.Add x，x
dictKeys.Add DebitKey，dictRows
结束如果
下一个
对于x = 0 To lastRow - 2
如果不是IsEmpty（arrMatchRow（x））和IsEmpty（arrMatchID（x））然后
rw = arrMatchRow（x） - 2
arrMatchRow（rw）= x + 2
ID = ID + 1
arrMatchID（x）= ID
arrMatchID（rw）= ID
Else
如果IsEmpty（arrMatchRow（x））然后
arrMatchRow ）=无匹配
结束如果
结束如果
下一个
范围（C2，C& lastRow）.Value = WorksheetFunction.Transpose（arrMatchRow）
Range（D2，D& lastRow）.Value = WorksheetFunction.Transpose（arrMatchID）
设置dictKeys = Nothing
Set dictRows = Nothing
End Sub
First, I'd like to apologize for this poor question and I hope it doesn't upset anyone here. Since I'm not that good at speaking English to convey my request, so please have a look to the cited links in order to get a clear explanation to this question.
I'm trying to find the solution to this question of mine. I started my attempt by searching for the same number in column A and column B (Debit and Credit). I used the looping-trough-array method to do it instead of employing the Find function like this question since I think it's faster.
Suppose that I have the following set data in Sheet1 and start from row 1 column A:
D e b i t Cr e d i t
20 13
14 13
13 14
14 17
19 19
11 20
17 14
20 12
19 19
20 15
20 12
13 11
12 19
13 20
19 19
20 11
11 16
10 16
19 19
20 11
Now, I'd like to process the data set above to something like this:
Basically, I need to find the same value of debit and credit in a specific row and match it with debit and credit in another row. Column C (Row) indicates the matched values. For example, the debit value in row 2 match with the credit value in row 15 and vice-versa. And numbers in column D (ID Match) are the label numbers to indicate the order of the matched data that's found first. This is my code in an attempt to implement the task:
Public i As Long, j As Long, k As Long, Last_Row As Long
Public DC, Row_Data, ID_Match
Sub Quick_Match()
T0 = Timer
k = 0
Last_Row = Cells(Rows.Count, "A").End(xlUp).Row
ReDim DC(1 To Last_Row - 1, 1 To 2)
ReDim Row_Data(1 To Last_Row - 1, 1 To 1)
ReDim ID_Match(1 To Last_Row - 1, 1 To 1)
DC = Range("A2:B" & Last_Row)
For i = 1 To Last_Row - 1
If DC(i, 1) <> "" Then
k = k + 1
For j = 1 To Last_Row - 1
If DC(i, 1) <> DC(i, 2) Then
If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
Call Row_Label
Exit For
Else
Row_Data(i, 1) = "No Match"
End If
Else
If i <> j Then
If DC(i, 1) = DC(j, 1) And DC(i, 2) = DC(j, 2) Then
Call Row_Label
Exit For
Else
Row_Data(i, 1) = "No Match"
End If
End If
End If
Next j
End If
If Row_Data(i, 1) = "No Match" Then
k = k - 1
End If
Next i
Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
InputBox "The runtime of this program is ", "Runtime", Timer - T0
End Sub
Sub Row_Label()
Row_Data(i, 1) = j + 1
ID_Match(i, 1) = k
Row_Data(j, 1) = i + 1
ID_Match(j, 1) = k
DC(i, 1) = ""
DC(i, 2) = ""
DC(j, 1) = ""
DC(j, 2) = ""
End Sub
Though it's a bit slow on its performance, but it works fine. It completes in about 25 seconds on my machine for processing 10,000 rows of data (the data set file can be downloaded on this link for testing the running time of your code and mine). So I'm wondering if there is a more effective way for doing this. Could anyone come up with either a shorter version or a quicker version? Please do share your attempt.
I reworked my previous answer introducing a second loop; so that our ID numbers will match.
Sub DebitCreditCrossMatch()
Dim dictKeys As Object, dictRows As Object
Dim DebitKey As String, CreditKey As String
Dim arrDebit, arrCredit, items, keys
Dim arrMatchRow(), arrMatchID()
Dim ID As Long, rw As Long, x As Long, lastRow As Long
lastRow = Cells(Rows.count, "A").End(xlUp).Row
arrDebit = Range("A1", "A" & lastRow).Value
arrCredit = Range("B1", "B" & lastRow).Value
ReDim arrMatchID(lastRow - 2)
ReDim arrMatchRow(lastRow - 2)
Set dictKeys = CreateObject("Scripting.Dictionary")
For x = 2 To lastRow
DebitKey = arrDebit(x, 1) & ":" & arrCredit(x, 1)
CreditKey = arrCredit(x, 1) & ":" & arrDebit(x, 1)
If dictKeys.Exists(CreditKey) Then
Set dictRows = dictKeys(CreditKey)
items = dictRows.items
keys = dictRows.keys
rw = CLng(items(0))
arrMatchRow(x - 2) = rw
arrMatchRow(rw - 2) = x
dictRows.Remove keys(0)
If dictRows.count = 0 Then dictKeys.Remove CreditKey
ElseIf dictKeys.Exists(DebitKey) Then
Set dictRows = dictKeys(DebitKey)
dictRows.Add x, x
Else
Set dictRows = CreateObject("Scripting.Dictionary")
dictRows.Add x, x
dictKeys.Add DebitKey, dictRows
End If
Next
For x = 0 To lastRow - 2
If Not IsEmpty(arrMatchRow(x)) And IsEmpty(arrMatchID(x)) Then
rw = arrMatchRow(x) - 2
arrMatchRow(rw) = x + 2
ID = ID + 1
arrMatchID(x) = ID
arrMatchID(rw) = ID
Else
If IsEmpty(arrMatchRow(x)) Then
arrMatchRow(x) = "No Match"
End If
End If
Next
Range("C2", "C" & lastRow).Value = WorksheetFunction.Transpose(arrMatchRow)
Range("D2", "D" & lastRow).Value = WorksheetFunction.Transpose(arrMatchID)
Set dictKeys = Nothing
Set dictRows = Nothing
End Sub
这篇关于使用VBA Excel在其他列中使用相同数字的列中的数字进行匹配的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
