Excel VBA：匹配行数据并删除
我每个月都必须完成一些帐目对账，这可能会很痛苦。 基本上我运行一个报告，在过去的2个月内返回帐户中的所有交易。 这份报告通常是几千行。 除一个或两个例外之外的每个交易都应该具有“倒转”的始发TRXtypes。 例如，这是如何工作的，会计师将在2016年1月31日对该账户进行借logging入，然后将撤销date设置为2/1/2016。 一个相同的条目将自动在2016年2月1日，但它会被翻转到一个信用条目，如果进行正确的话，两个月之间的条目余额将净额为零。 但是，会计师一定会不小心，input“标准”，而不是设定一个相反的date。 因此，帐户中留下了未结余额。 我的调查的目的是要find这些不正确的“标准”条目，不通过会计，通知会计师，并确保他们进行必要的更正条目。 侦察中最痛苦的部分是通过正确的所有条目，以find几个不正确的一个。 下面是报告的图片：
本报告的date范围为01/01 / 2016-02 / 29/2016。 id能够做的是循环“Journal Entry”列并find如下所示的匹配项：
您将注意到，第一笔交易的交易date为2016年1月31日，借记余额为TRX，date为2/01/2016，并且有余额。 这个项目是正确的，我可以从我的报告中删除它。 如果我有一个macros将为我照顾这一步，那将是最理想的，因为这是最耗时的部分。 我已经试过为此编写代码，但还没有拿出任何有效的东西。 以下是我的思考过程。
DataLastRow = Sheets(DataSheet).Range("A" & Rows.Count).End(xlUp).Row Set JERange = Sheets(DataSheet).Range("C6:C" & DataLastRow) For Each JE1 In JERange 'declare JE1's TRX Date 'declare JE1's JE # Set SearchRange = Sheets(DataSheet).Range(Cell.Offset(1, 0).Address(False, False) & ":C" & DataLastRow) For Each JE2 in SearchRange 'declare JE2's TRX Date 'declare JE2's JE # 'IF statement to check for matching JE #'s and Non-Matching TRX Dates between JE1 and JE2 Next JE2 Next JE1 我想首先强调比赛。 任何帮助将不胜感激。
如果你只需要find只有一个JE号码的人，这应该有所帮助。 这将计算JE的实例，将该数字放在另一列中并过滤“1”
Sub test() Dim w As Range Dim iVal As Integer lrow = Range("C5", Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Count For Each w In Range("C5:C" & lrow).Cells iVal = Application.WorksheetFunction.CountIf(Range("C5:C" & lrow), w.Value) w.Offset(0, 1).Value = iVal '<---change this offset to an empty column Next w 'change this to filter on the column you set above in the offset 'change "fields:=2" to the field that shows the count Worksheets("Sheet1").Range("C5").AutoFilter field:=2, Criteria1:="1", VisibleDropDown:=False End Sub
假设你想根据这个条件得到“重复”：
- [
Credit Amount]等于[Debit Amount]
对于大数据量我build议使用ADODB.Recordset，这将比通过单元格的任何循环快得多。
看例子macros：
Option Explicit Sub GetSpecificRows() 'declare variables Dim oConn As ADODB.Connection Dim oRst As ADODB.Recordset Dim sConn As String Dim sFileName As String Dim sQry As String 'on error go to error handler On Error GoTo Err_GetSpecificRows 'get the current file name (containing this macro) sFileName = ThisWorkbook.FullName 'define connection string sConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';" 'set query statement sQry = "SELECT A.[TRX Date], A.[Journal Entry], A.[Debit Amount], A.[Credit Amount]" & vbCr & _ "FROM [DataSheet$B5:H20] AS A INNER JOIN (" & vbCr & _ "SELECT [TRX Date], [Journal Entry], [Debit Amount], [Credit Amount]" & vbCr & _ "FROM [DataSheet$B5:H20]" & vbCr & _ ") AS B ON A.[Journal Entry] = B.[Journal Entry] AND A.[Debit Amount] = B.[Credit Amount]" 'create and open connection Set oConn = New ADODB.Connection With oConn .ConnectionString = sConn .Open End With 'create and open recordset Set oRst = New ADODB.Recordset oRst.Open Source:=sQry, ActiveConnection:=oConn, CursorType:=adOpenStatic, LockType:=adLockReadOnly 'MsgBox sQry, vbInformation, oRst.RecordCount 'clear destination sheet ThisWorkbook.Worksheets(2).Range("B6:E20").Clear 'copy data from recordset ThisWorkbook.Worksheets(2).Range("B6").CopyFromRecordset oRst 'exit instructions Exit_GetSpecificRows: On Error Resume Next If Not oRst Is Nothing Then oRst.Close: Set oRst = Nothing If Not oConn Is Nothing Then oConn.Close: Set oConn = Nothing Exit Sub 'error handler Err_GetSpecificRows: MsgBox Err.Description, vbExclamation, Err.Number Resume Exit_GetSpecificRows End Sub
注：以上代码正在search符合条件的数据，并将这些数据复制到同一工作簿中的另一个工作表中。 如果你想执行删除操作，你需要创buildADODB.Command 。
欲了解更多信息，请参阅：
ADODB.Connection
ADODB.Recordset
Excel的连接string
谢谢您的帮助！ 我很快把它们打了一遍，效果很好：
Set JERange = Sheets(DataSheet).Range("C6:C" & DataLastRow) For Each JE1 In JERange JEMatch = False TRXTypeMatch = False TRXDateNoMatch = False JENum1 = JE1.Value TRXDate1 = JE1.Offset(0, -1).Value TRXType1 = JE1.Offset(0, 10).Value Set SearchRange = Sheets(DataSheet).Range(JE1.Offset(1, 0).Address(False, False) & ":C" & DataLastRow) For Each JE2 In SearchRange JEMatch = False TRXTypeMatch = False TRXDateNoMatch = False JENum2 = JE2.Value TRXDate2 = JE2.Offset(0, -1).Value TRXType2 = JE2.Offset(0, 10).Value If JENum1 = JENum2 Then JEMatch = True End If If TRXDate1 <> TRXDate2 Then TRXDateNoMatch = True End If If TRXType1 = TRXType2 Then TRXTypeMatch = True End If If JEMatch = True And TRXDateNoMatch = True And TRXTypeMatch = True Then JE1.Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With JE2.Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If Next JE2 Next JE1