如果表名与单元格值匹配，我如何运行代码？

Question

我在示例表上进行测试，因为实际的表有机密数据。

我们有每个公司的表格，我们在上面列出了对一个经理或一组经理的警告，然后将它们分类为轻度或严重。我想为每个经理计算它们，考虑到，如果它是对多个经理的相同警告，我们将它们放在同一个单元格中。

Sub TesteA3()
'code 1:Set ID number for each company (company names can change so I needed a fixed ID)
Dim rcell As Range
Dim rrng As Range
Set rrng = Range("A2:A800")
'Since I'm using a sum to diffentiate the ID, I make sure to clear the range before any
Range("C2:E800").ClearContents
For Each rcell In rrng
    If rcell.Value = rcell.Offset(-1, 0).Value And IsEmpty(rcell) = False Then
        rcell.Offset(0, 5).Value = rcell.Offset(-1, 5).Value
    ElseIf rcell.Value <> rcell.Offset(-1, 0).Value And IsEmpty(rcell) = False Then
        rcell.Offset(0, 5).Value = rcell.Offset(-1, 5).Value + 1
    Else: If IsEmpty(rcell.Value) = True Then GoTo proximo
    End If
proximo:
Next rcell
'code 3:Sets an actual ID for each company. Since I'll use these ID's on the table later, I need them to not be plain numbers
Dim ncell As Range
Dim rrng2 As Range
Set rrng2 = Sheets("Sheet1").Range("F2:F800")
For Each ncell In rrng2
    If IsEmpty(ncell) = False Then
        ncell.Offset(0, -1).Value = "Company" & ncell.Value
        ncell.Clear
    Else
        GoTo proximo4
    End If
proximo4:
Next ncell
'code 3: Checks the erros and counts them
Dim rcell3 As Range
Dim rcell2 As Range
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Range("B2:B12")
Set rng2 = Range("I3:I12")
For Each rcell3 In rng1
    For Each rcell2 In rng2
        If InStr(1, rcell2.Value, rcell3.Value) > 0 And rcell2.Offset(0, -2).Value = "X" Then
            rcell3.Offset(0, 1).Value = rcell3.Offset(0, 1).Value + 1
        ElseIf InStr(1, rcell2.Value, rcell3.Value) > 0 And rcell2.Offset(0, -1).Value = "X" Then
            rcell3.Offset(0, 2).Value = rcell3.Offset(0, 2).Value + 1
        End If
    Next rcell2
Next rcell3
End Sub

主要问题是有时经理的名字是相同的，并且由于我在 H:H 范围内运行 for each 而不是每个表，因此每个公司都会被计算两次，我必须为每个特定的运行代码 2如果表的名称与公司的 ID 匹配，则为表。我已经用它们各自的 ID 命名了表（示例表中分别为 Company1、Company2，所以这不是问题。

我正在尝试类似的东西

Dim co as ListObject
For each co In ActiveSheet.ListObjects
If ListObject.name = Range(rcell3).Offset(3,0).Value Then
''Run the code 2

我很难用桌子做

If

s和

For Each

s。

Answer 1

通过遍历所有表来查找表名是

LIKE "Company*"

的表来分别处理每个公司表

Option Explicit

Sub TesteA3()

    Dim ws As Worksheet
    Dim lastrow As Long, r As Long, n As Long
    Dim sCo As String, sLastCo As String
    
    Set ws = ThisWorkbook.Sheets("Sheet1") ' or whatever
    
    ' add CompanyID to column E
    With ws
       lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
       .Range("C2:E" & lastrow).Clear
       n = 0
       For r = 2 To lastrow
            sCo = Trim(.Cells(r, "A"))
            If Len(sCo) > 0 Then ' skip blank rows
                If sCo <> sLastCo Then
                    n = n + 1
                End If
                sLastCo = sCo
                .Cells(r, "E") = "Company" & n
            End If
       Next
    End With
    
    Dim tbl As ListObject, tblrow As Range, ID As String
    Dim colSevere As Long, colLight As Long, colMgr As Long
    Dim sSevere As String, sLight As String, sMgr As String
    
    ' process each company table
    For Each tbl In ws.ListObjects
        ID = tbl.Name
        If ID Like "Company*" Then
            
            colSevere = tbl.ListColumns("Severe").Index
            colLight = tbl.ListColumns("Light").Index
            colMgr = tbl.ListColumns("Manager").Index
            
            ' scan table rows
            For Each tblrow In tbl.DataBodyRange.Rows
                sSevere = UCase(tblrow.Cells(, colSevere))
                sLight = UCase(tblrow.Cells(, colLight))
                
                If sSevere = "X" Or sLight = "X" Then
                    sMgr = tblrow.Cells(, colMgr)
                    
                    ' scan company/manager table
                    For r = 2 To lastrow
                         ' match company ID and manager
                         If ws.Cells(r, "E") = ID _
                            And InStr(sMgr, ws.Cells(r, "B")) > 0 Then
                                ' increase counts
                                If sSevere = "X" Then
                                    ws.Cells(r, "C") = ws.Cells(r, "C") + 1
                                End If
                                If sLight = "X" Then
                                    ws.Cells(r, "D") = ws.Cells(r, "D") + 1
                                End If
                         End If
                    Next
                End If
            Next
       End If
    Next
    
     MsgBox "Done", vbInformation

End Sub