好吧，抱歉，如果我违反了这里的规则
我解决这个问题的方法是将我的数据值设置到一个数组中，然后将借记金额设置到一个变量中，然后循环遍历数据集以找出是否有任何贷项与可变借记金额匹配 - 接下来我将组织匹配记入借方，然后仔细检查并整理数组，然后将结果粘贴到工作表中。
我很想在更多数据上尝试一下，但是：
'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
好吧 - 稍微改变一下 - 我不确定我们现在是否需要在数组中向下移动末尾的情况，因为在主配对 j 循环中退出，但它按原样工作 - 无需花费太多更多时间我会让你玩它。使用断点和本地窗口 / debug.assert 来查看它在做什么。希望这可以帮助
