[英]Find, cut, and insert row to match the value of debit and credit in VBA Excel
我在Sheet1中具有以下設置數據,並從第4行A列(其中第3行的標題)開始:
No Date Code Name Remarks D e b i t Cr e d i t
1 4/30/2015 004/AB/01/04/15 Anna YES 40239.66 0.00
2 2/16/2015 028/AA/01/02/15 Andy NO 0.00 2205.49
3 1/31/2015 021/DR/04/01/15 Jim YES 167.60 0.00
4 7/14/2015 083/RF/01/07/15 Anna YES 3822.60 0.00
5 8/6/2015 030/AB/01/08/15 Anna NO 0.00 11267.96
6 1/15/2015 020/TY/01/01/15 Barry 0.00 5237.84
7 7/14/2015 024/HU/01/07/15 Anna NO 0.00 3822.60
8 1/31/2015 039/JK/01/01/15 YES 0.00 1780.84
9 1/27/2015 007/ER/01/01/15 Jim NO 5237.84 0.00
10 4/29/2015 077/FX/01/04/15 Barry NO 0.00 40239.66
11 1/3/2015 001/OX/10/01/15 Andy NO 33074.03 0.00
12 8/10/2015 001/PR/01/08/15 Nicholas 11267.96 0.00
13 10/31/2015 007/TX/09/10/15 Jim 1780.84 0.00
14 2/28/2015 071/QR/01/02/15 Andy YES 2205.49 0.00
15 1/7/2015 007/OM/02/01/15 Nicholas 8873.25 0.00
而且,我需要根據借方和貸方的值將上述數據按相同的順序排列在同一張表中 ,只要借方和貸方的值: x和y后跟借方和貸方的值: y和x (最好x> y ),其中不匹配的數據將放置在排列表的底部。 例如這樣的事情 :
No Date Code Name Remarks D e b i t Cr e d i t
14 2/28/2015 071/QR/01/02/15 Andy YES 2205.49 0.00
2 2/16/2015 028/AA/01/02/15 Andy NO 0.00 2205.49
4 7/14/2015 083/RF/01/07/15 Anna YES 3822.60 0.00
7 7/14/2015 024/HU/01/07/15 Anna NO 0.00 3822.60
12 8/10/2015 001/PR/01/08/15 Nicholas 11267.96 0.00
5 8/6/2015 030/AB/01/08/15 Anna NO 0.00 11267.96
9 1/27/2015 007/ER/01/01/15 Jim NO 5237.84 0.00
6 1/15/2015 020/TY/01/01/15 Barry 0.00 5237.84
13 10/31/2015 007/TX/09/10/15 Jim 1780.84 0.00
8 1/31/2015 039/JK/01/01/15 YES 0.00 1780.84
1 4/30/2015 004/AB/01/04/15 Anna YES 40239.66 0.00
10 4/29/2015 077/FX/01/04/15 Barry NO 0.00 40239.66
11 1/3/2015 001/OX/10/01/15 Andy NO 33074.03 0.00
15 1/7/2015 007/OM/02/01/15 Nicholas 8873.25 0.00
3 1/31/2015 021/DR/04/01/15 Jim YES 167.60 0.00
老實說,我無法提供正確的代碼來做到這一點,這確實使我發瘋。 這是我失敗的嘗試之一,我已經嘗試過類似的事情
Sub MatchingDebitAndCredit()
Dim i As Long, j As Long, Last_Row As Long
Last_Row = Cells(Rows.Count, "F").End(xlUp).Row
For i = 4 To Last_Row
For j = 4 To Last_Row
If Cells(i, "F").Value = Cells(j, "G").Value And Cells(i, "G").Value = Cells(j, "F").Value Then
Rows(i).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(j).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Exit For
End If
Next j
Next i
End Sub
我無法在同一張工作表中復制匹配的數據到Sheet2中,但是它失敗了,程序完成后在Sheet2中什么也沒有返回。 我打算使用數組和Find函數來執行此操作,因為數據集的大小非常大,但是如果不能使用工作表,該怎么辦呢? 請問有人可以幫我嗎?
好的,抱歉,如果我違反了這里的規定
我要解決的方法是將數據值設置為數組,然后將借方金額設置為變量,然后遍歷數據集以查找是否有任何貸方與變量借方金額匹配-接下來,我將組織匹配到他們的借方,然后整理並整理陣列,使其更清潔,然后將結果粘貼到工作表中。
我很想在更多數據上嘗試一下,但是:
'constants declared for column numbers within array
Const lDEBITCOL As Long = 6
Const lCREDITCOL As Long = 7
Dim rA 'main array
Dim iMain&, stackRow& 'module long variables
Dim debitAmt# 'module double variable
Sub raPairMain()
Dim j&
rA = ActiveSheet.UsedRange 'setting activesheet into array
For iMain = 2 To UBound(rA) 'imain loop through ra rows
debitAmt = rA(iMain, lDEBITCOL) 'variable to check through credits in j loop
'efficiency logical comparison for 0 values in debit amount
'debit amount is 0 skip j loop
If debitAmt Then
For j = 2 To UBound(rA) 'j loop through ra rows
If debitAmt Then 'necessary for matches on the last line of data
'matching variable to credit amount in array
If debitAmt = rA(j, lCREDITCOL) Then
'function to shift down rows within array
'first parameter(imain) is destination index
'second parameter is index to insert
'imain +1 to insert under current debit amount
shiftRaRowDown iMain + 1, j
Exit For
End If 'end of match for debit amount
End If
Next j 'increment j loop
End If 'end of efficiency logical comparison
Next iMain 'increment imain loop
OrganizeArray 'procedure to stack array by matches
'setup array2 for dropping into worksheet to keep headings
'to preserve the table structure if present
ReDim rA2(UBound(rA) - 2, UBound(rA, 2) - 1)
Dim i&
For i = 2 To UBound(rA)
For j = LBound(rA, 2) To UBound(rA, 2)
rA2(i - 2, j - 1) = rA(i, j)
Next j
Next i
'drop array2 into worksheet with offset
With ActiveSheet
.Range(.Cells(2, 1), .Cells(UBound(rA), UBound(rA, 2))) = rA2
End With
End Sub
Sub OrganizeArray()
stackRow = 2 'initiate top row for stacking based on column headings
'could also just constantly use row 2 and shift everything down
Dim i&, j& 'sub procedure long variables
Dim creditAmt# 'sub procedure double variable
For i = 2 To UBound(rA) 'initiate loop through ra rows
debitAmt = rA(i, lDEBITCOL) 'set variable to find
'efficiency check to bypass check if debit amount is null
If debitAmt Then
If i + 1 < UBound(rA) Then 'logical comparison for last array index
'determine if next line is equal to variable debit amt
If debitAmt = rA(i + 1, lCREDITCOL) Then
shiftRaRowDown stackRow, i 'insert in array position stack row as variable next top row
stackRow = stackRow + 1 'increment stack row based on new top row
'noted in primary procedure
shiftRaRowDown stackRow, i + 1
stackRow = stackRow + 1 'increment stack row for new top of array
End If 'end comparison for variable debit amount
End If 'end comparison for upper boundary of ra
End If 'end comparison for null debit value
Next i 'increment i loop
End Sub
Sub shiftRaRowDown(ByVal destinationIndex As Long, ByVal insertRow As Long)
Dim i&, j& 'sub primary long variables for loop
'for anytime the destination matches the insertion row exit sub procedure
If destinationIndex = insertRow Then Exit Sub
'if the destination row for debit was found after the credit amount
'call the procedure again reversing the inputs and offsetting
'debit / credit hierarchy
If destinationIndex > insertRow Then
shiftRaRowDown insertRow, destinationIndex - 1
Select Case iMain
Case Is < UBound(rA) - 1
iMain = iMain + 1 'increment main sub procedure i
'reset debit amount to new main i value if it is within the array boundary
Case Is <= UBound(rA)
debitAmt = rA(iMain, lDEBITCOL)
Case Else
debitAmt = 0 'necessary for matches on the last line of data
End Select
Exit Sub 'exit recursive stack
End If
'get boundaries for a temporary storage array for row to insert
ReDim tmparray(UBound(rA, 2))
'function below will place data from array to move into temporary array
tmparray = RowToInsert(insertRow)
'initiate loop from the array copied temporary array back to the
'row where it is being inserted
For i = insertRow To destinationIndex Step -1
'loop through columns to replace values
For j = LBound(rA, 2) To UBound(rA, 2)
rA(i, j) = rA(i - 1, j) 'values from previous row i-1 are set
Next j
Next i
'loop through temporary array to place copied temporary data
For i = LBound(rA, 2) To UBound(rA, 2)
'temporary array is single dimension
rA(destinationIndex, i) = tmparray(i - 1)
Next i
End Sub
Function RowToInsert(ByVal arrayIndex As Long) As Variant
ReDim tmp(UBound(rA, 2) - 1) 'declare tempArray with boundaries offset for 0 address
Dim i& 'sub procedure long iterator
If arrayIndex > UBound(rA) Then
RowToInsert = tmp
Exit Function
End If
For i = LBound(tmp) To UBound(tmp) 'loop to store temporary values from array
tmp(i) = rA(arrayIndex, i + 1)
Next i
RowToInsert = tmp 'setting function = temporary array
End Function
好的-對其進行了一些更改-我不確定由於主要paring j循環中存在退出,所以現在不知道數組末尾是否需要這種情況,但是它按原樣進行-無需花費很多更多的時間在它,我會讓你玩。 使用斷點和您的本地窗口/ debug.assert來查看其工作情況。 希望這可以幫助
僅使用助手功能進行排序似乎比較容易。 例如
No Date Code Name Remarks Debit Credit match sum
13 10/31/2015 007/TX/09/10/15 Jim 1,780.84 0.00 -1 1,780.84
8 1/31/2015 039/JK/01/01/15 YES 0.00 1,780.84 -1 1,780.84
14 2/28/2015 071/QR/01/02/15 Andy YES 2,205.49 0.00 -1 2,205.49
2 2/16/2015 028/AA/01/02/15 Andy NO 0.00 2,205.49 -1 2,205.49
4 7/14/2015 083/RF/01/07/15 Anna YES 3,822.60 0.00 -1 3,822.60
7 7/14/2015 024/HU/01/07/15 Anna NO 0.00 3,822.60 -1 3,822.60
9 1/27/2015 007/ER/01/01/15 Jim NO 5,237.84 0.00 -1 5,237.84
6 1/15/2015 020/TY/01/01/15 Barry 0.00 5,237.84 -1 5,237.84
12 8/10/2015 001/PR/01/08/15 Nicholas 11,267.96 0.00 -1 11,267.96
5 8/6/2015 030/AB/01/08/15 Anna NO 0.00 11,267.96 -1 11,267.96
1 4/30/2015 004/AB/01/04/15 Anna YES 40,239.66 0.00 -1 40,239.66
10 4/29/2015 077/FX/01/04/15 Barry NO 0.00 40,239.66 -1 40,239.66
3 1/31/2015 021/DR/04/01/15 Jim YES 167.60 0.00 0 167.60
15 1/7/2015 007/OM/02/01/15 Nicholas 8,873.25 0.00 0 8,873.25
11 1/3/2015 001/OX/10/01/15 Andy NO 33,074.03 0.00 0 33,074.03
我不能嘗試代碼,而只是為了展示想法(假設數據在Sheet2!A1:G16中)
Sub MatchingDebitAndCredit()
With Worksheets("Sheet2").Range("A2:I16") ' exclude the headers row and include the columns for the helper functions
.Columns("H").Formula = "= CountIf( $F:$F, $G2 ) * -( $G2 > $F2 ) + CountIf( $G:$G, $F2 ) * -( $F2 > $G2 ) " ' you can probably simplify this formula or combine it with the other one
.Columns("I").Formula = "= $F2 + $G2 "
.Sort key1:=.Range("H1"), key2:=.Range("I1"), key3:=.Range("G1") ' sort by match, then by sum, and then by Credit (or adjust to your preference with Record Macro)
.Columns("H:I").Clear ' optional to clear the helper functions
End With
End Sub
改善
好的,最后我找到了解決此問題的方法。 抱歉,如果花費時間太長。 我還要感謝克萊德和斯萊給我的答案。 我真的很感激。
我沒有剪切整個匹配數據的行,而是將其插入一對被認為很耗時的對的行下方,而是根據匹配的順序將相同的值分配給匹配的對(我稱這些數字為ID Match) ,然后刪除 (分配vbNullString
)匹配的對,這樣它們就不會通過遍歷數組而再次被處理。 我還將內部循環的起點設置為從i = 1
到j = i+1
因為要處理的下一個訂單位於數據下方,因為在其下找不到匹配的下一個候選商品。 將所有數據標記為連續數字后,我將根據列ID匹配(列I)以升序對所有數據進行排序。 為了提高代碼性能,我將F&G列中的數據復制到一個數組中,並使用.Value2
而不是Excel的默認設置,因為它僅采用該范圍的值而沒有其格式(借方和貸方為會計編號格式) 。 這是我用來實現此任務的代碼:
Sub Quick_Match()
Dim i As Long, j As Long, k As Long, Last_Row As Long
Dim DC, Row_Data, ID_Match
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).Value2
For i = 1 To Last_Row - 2
If DC(i, 1) <> vbNullString Then
k = k + 1
For j = i + 1 To Last_Row - 1
If DC(j, 2) <> vbNullString Then
If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
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) = vbNullString: DC(i, 2) = vbNullString
DC(j, 1) = vbNullString: DC(j, 2) = vbNullString
Exit For
End If
End If
Next j
End If
If Row_Data(i, 1) = vbNullString Then
Row_Data(i, 1) = "No Match": k = k - 1
End If
Next i
Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
Columns("A:D").Sort key1:=Range("D2"), order1:=xlAscending, Header:=xlYes
End Sub
它平均完成不到2.75秒 (比編輯前版本快兩倍,並且更短)的任務,可在我的計算機上處理大約11,000行。 有關詳細信息 ,請參見以下帖子 。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.