如何分组循环数据表

Question

我想在 Excel VBA 宏中检查标准化表格中的单元格（意味着修复列标题，但没有修复位置，以便表格可以在修复命名工作表中的任何位置开始）。

以下是该表的示例：

示例表说明： 该数据用于开票。在名为“发票 ID”的 S 列中，有发票的 ID，这意味着第 72 行（ID=1）是一张发票，有一个发票位置，因此总共只有一笔金额（此处为 5 欧元）。第二张发票（ID=2）包含两个发票仓位，总金额为10港币（包括8+2港币仓位）。

使用 VBA 宏，我想检查表中每个单元格的条目和格式是否正确。另外，对于多位置发票的情况，我想检查总金额是否是各个位置的正确总和（在发票2的示例中：我想检查总金额10是否是正确的总和8 和 2)。 总金额始终放在发票组的第一行。

我已经创建了以下代码，但它不起作用。

有人知道问题是什么或代码如何工作吗？

非常感谢您的帮助！

史蒂菲

Option Explicit
Private WB As Workbook, ws As Worksheet
Private i As Long, lEnde As Long, strHeader As String
Private rngFind As Range, booCheck As Boolean, rngHeader As Range, rngFormula As Range, rngKey As Range, rngUsed As Range
Private idCol As Range
Private headerRow As Range
Private dataRange As Range
Private currentID As Variant
Private previousID As Variant
Private groupStartRow As Long
Private groupEndRow As Long
Private lastRow As Long
Private lastCol As Long
Private numRows As Long 
Private isMultiLine As Boolean
Private cell As Range
Private col As Range
Private groupRange As Range
Private groupRow As Range
Private rowIndex As Long
Private cellRef As Range
Private cellValue As Variant
Private cellFormula As String
Private cellFormat As String
Private containsLineBreak As Boolean
 
Function Main_Check(ByVal strFilePath As String) As String
On Error GoTo ErrorHandler
If strFilePath = "" Then GoTo ErrorHandler
Set WB = Workbooks.Open(strFilePath)
Set ws = WB.Worksheets("SpecificSheet")
With ws
 '//Define last row and column which must be processed
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row
lColEnde = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
'//Find beginning of table
Set rngFind = .Cells.Find(what:=Settings.Cells(Settings.Range("Header_Start").Row + 1, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If rngFind Is Nothing Then
    booCheck = False
    End
End If
 
lEnde = .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2, 2).End(xlUp).Row

Set rngUsed = .Range(rngFind.Address, .Cells(lEnde, lColEnde))
booCheck = IsErrorAll(rngUsed)
 
'//Define header row und ID-column
Set headerRow = rngUsed.EntireRow
lastRow = .Cells(.Rows.Count, rngUsed.Column).End(xlUp).Row
lastCol = .Cells(headerRow.Row, .Columns.Count).End(xlToLeft).Column
Set idCol = .Range(.Cells(headerRow.Row + 1, rngUsed.Column), .Cells(lastRow, lastCol))

'//Group for ID
currentID = idCol.Cells(1, 1).Value

    'Check if first group has ID = 1
    If currentID <> 1 Then
        currentID.Interior.Color = vbRed
        booCheck = False
    End If
    If booCheck = False Then GoTo Ende

groupStartRow = idCol.Cells(1, 1).Row
previousID = currentID 'Initialize first group

For i = 2 To idCol.Rows.Count + 1 'Loop via IDs
    If i > idCol.Rows.Count Or idCol.Cells(i, 1).Value <> currentID Then
        'Group end reached
        groupEndRow = idCol.Cells(i - 1, 1).Row
    
        'Process group
        Call ProcessGroup(.Rows(groupStartRow & ":" & groupEndRow), .Rows(headerRow))
    
        'Check ongoing IDs
        If i <= idCol.Rows.Count Then
            Dim nextID As Variant
            nextID = idCol.Cells(i, 1).Value
            If nextID <> previousID + 1 Then
                idCol.Cells(i, 1).Interior.Color = vbRed
                booCheck = False
            End If
            If booCheck = False Then GoTo Ende
            previousID = nextID 'Set the new last ID
        End If
        
        'Start new group
        If i <= idCol.Rows.Count Then
            currentID = idCol.Cells(i, 1).Value
            groupStartRow = idCol.Cells(i, 1).Row
        End If
    End If
Next i
End Function

Sub ProcessGroup(groupRange As Range, headerRow As Range)
'Check if group is multi-line
isMultiLine = (groupRange.Rows.Count > 1)
 
'Check all columns and all rows of group
rowIndex = 1 'Initialize row index within group
If groupRange.Rows.Count = 1 And groupRange.Columns.Count = 1 Then
   Set cellRef = groupRange
Else
   Set cellRef = groupRange.Cells(1, 1)
End If
 
For Each groupRow In groupRange.Rows
Call Processing1(groupRow)
rowIndex = rowIndex + 1 'Increase row index
Next groupRow
End Sub
 
Sub Processing1(groupRow As Range)
   '//Invoice-ID (only formal check, content already checked)
    strKey = "ID"
    Set rngKey = Settings.Cells(1, 1).EntireColumn.Find(what:=strKey, LookIn:=xlValues, lookat:=xlWhole)
    strHeader = Settings.Cells(rngKey.Row, 2).Value
    Set rngHeader = ws.Range(rngFind, ws.Cells(rngFind.Row, lColEnde)).Find(what:=strHeader, LookIn:=xlValues, lookat:=xlWhole)
    cellRef = ws.Cells(groupRow.Row, rngHeader.Column) 
    containsLineBreak = (InStr(1, cellRef.Value, vbLf) > 0)
    
    If (cellRef.Value Like "#" Or cellRef.Value Like "##" Or cellRef.Value Like "###") 
    And cellRef.NumberFormat = "General" And Not containsLineBreak And Not Left(cellRef.Formula, 2) = "=+" Then
        cellRef.Interior.Pattern = xlNone
    Else
        cellRef.Interior.Color = vbRed
        booCheck = False
    End If
    
    '//.... (further checks for further columns)
End Sub

Answer 1

我为你编写了一个代码，通过 S 列找到 ID 并验证总数。只有一个位置的 ID 在此代码中将被标记为不正确。

请更改相关名称和列，例如（工作表名称为发票），说明将位于 AA 列（i,29）。

    Sub CheckInvoices()
        
        
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets("Invoices") ' Change to your actual sheet name
    
        Dim lastRow As Long
        lastRow = ws.Cells(ws.Rows.Count, "S").End(xlUp).Row ' Find the last row with data in column S
    
    
        Dim i As Long
        Dim currentInvoiceID As Long
        Dim sumPositions As Double
        Dim totalAmount As Double
        Dim isTotalAmountRow As Boolean
        Dim invoiceStartRow As Long
    
        On Error GoTo ErrorHandler
    
        For i = 2 To lastRow ' Assuming row 1 is headers
            If IsNumeric(ws.Cells(i, 19).Value) Then ' Check if cell in column S contains a numeric value (Invoice ID)
                
             If currentInvoiceID <> ws.Cells(i, 19).Value Then ' New invoice found
                    
              If currentInvoiceID <> 0 Then ' Skip the first iteration
                        ' Check previous invoice's total amount and write validation message
                If sumPositions = totalAmount Then
                            ws.Cells(invoiceStartRow, 27).Value = "Sum of Positions " & currentInvoiceID & " are OK"
                        
                  Else
                            ws.Cells(invoiceStartRow, 27).Value = "Sum of Positions " & currentInvoiceID & " is not correct"
                        
                End If
            
               End If
                    ' Reset for the new invoice
                    currentInvoiceID = ws.Cells(i, 19).Value
                    sumPositions = 0
                    isTotalAmountRow = True
                    invoiceStartRow = i ' Track the starting row of the invoice
                
              End If
                
                ' Check if it's the total amount row
                If isTotalAmountRow Then
                    totalAmount = ws.Cells(i, 24).Value ' Assuming total amount is in column X
                    isTotalAmountRow = False
                
               Else
                    ' Sum the positions
                    sumPositions = sumPositions + ws.Cells(i, 24).Value ' Assuming position amounts are in column X
                
             End If
            
            End If
        
        Next i
        
        ' Check last invoice's total amount and write validation message
        If currentInvoiceID <> 0 Then ' Ensure it's not the first iteration
            
              If sumPositions = totalAmount Then
                ws.Cells(invoiceStartRow, 27).Value = "Sum of Positions " & currentInvoiceID & " are OK"
            
                 Else
                ws.Cells(invoiceStartRow, 27).Value = "Sum of Positions " & currentInvoiceID & " is not correct"
            
                   End If
        
               End If
    
        Exit Sub
    
    ErrorHandler:
    
        MsgBox "Error " & Err.Number & ": " & Err.Description & " at row " & i & " column " & invoiceStartRow
    
    
    End Sub