匹配单元格并将其复制到摘要工作表/VBA

我需要找到一种方法将数据从多个工作表复制到摘要工作表中。 数据来自的图纸看起来都是这样的（块的数量和大小各不相同）

账户号码在顶部一行，不同数量的不同警报在侧面，到处都是多个区块

我的目标是复制并粘贴到此表中：

左边是账号，上面是不同的警报。每个工作表中的每个帐户都在该表中，每个警报都在该表中（唯一）。现在，我从工作表中获取数据的计划是迭代每个工作表，尝试将每个单元格与表中的警报和帐号匹配，然后插入它

Private Sub CommandButton24_Click()

Dim xSheet As Worksheet, DestSh As Worksheet
Dim Last As Long, crow As Long, ccol As Long
Dim copyRng As Range, destRng As Range, colSrc As Range, rowSrc As Range
Dim cRange As Range, copyTemp As Range, copyEnd As Range, copyStart As Range
Dim exchDest As Range, rowRange As Range
Dim numCol As Long, numRow As Long
Dim c As Range, q As Range
Dim uniqueVal() As Variant, x As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

Set destRng = DestSh.Range("E2")

'Loop through all worksheets and copy numbers to the
'summary worksheet.

For Each xSheet In ActiveWorkbook.Worksheets

    If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _

        'Set relevant range
        Set copyStart = xSheet.Range("A1")
        crow = xSheet.Cells(Rows.Count, 1).End(xlUp).Row
        ccol = xSheet.Cells(1, Columns.Count).End(xlToRight).Column
        Set copyEnd = xSheet.Cells(crow, ccol)
        Set copyRng = xSheet.Range(copyStart, copyEnd)

        'loop through range
        For Each c In copyRng.SpecialCells(xlCellTypeVisible)

            If IsNumeric(c) And c.Value <> "0" Then _ 'I am ignoring 0s since they will be added back later

                Set rowRange = xSheet.Range(c, c.EntireColumn.Cells(1)) 'set range from cell up to the top cell of the comment
                For Each q In copyRng.SpecialCells(xlCellTypeVisible) 'Loop through that range and find the Account number just above it and set it as rowSrc
                    If InStr(1, q.Value, "C-") Then _
                        Set rowSrc = q
                Next q


                Set colSrc = c.EntireRow.Offset(0).Cells(1) 'find alert connected with the number
                numCol = DestSh.Cells.Find(colSrc.Value, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column 'look for the column in which the same alert is listed
                numRow = DestSh.Cells.Find(rowSrc.Value, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row 'look for row in which the same account is listed 

                'Set destination
                Set destRng = DestSh.Cells(numRow, numCol)

                'Copy to destination Range
                c.Copy destRng

            End If

        Next c

    End If

Next xSheet


ExitTheSub:

Application.Goto DestSh.Cells(1)

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With


End Sub

Private子命令按钮24_单击（）
将xSheet设置为工作表，将DestSh设置为工作表
暗淡的持续时间一样长，乌鸦的持续时间一样长，卷心菜的持续时间一样长
Dim copyRng As Range、destRng As Range、colSrc As Range、rowSrc As Range
调宽范围范围、copyTemp范围、copyEnd范围、copyStart范围
变暗exchDest作为范围，行范围作为范围
暗数值和长数值一样，暗数值和长数值一样
尺寸c为量程，q为量程
Dim uniqueVal（）作为变量，x作为长度
应用
.ScreenUpdate=False
.EnableEvents=False
.Calculation=xlCalculationManual
以
设置destng=DestSh.Range（“E2”）
'循环浏览所有工作表并将编号复制到
'摘要工作表。
对于ActiveWorkbook.工作表中的每个xSheet
如果InStr（1，xSheet.Name，“ACCOUNT”）和xSheet.Range（“B1”）“无可用摘要”，则_
设置相关范围
设置copyStart=xSheet.Range（“A1”）
crow=xSheet.Cells（Rows.Count，1）.End（xlUp）.Row
ccol=xSheet.Cells（1，Columns.Count）.End（xlToRight）.Column
设置copyEnd=xSheet.Cells（crow、ccol）
设置copyRng=xSheet.Range（copyStart、copyEnd）
"环过射程",
对于每个c-In-copyRng.SpecialCells（xlCellTypeVisible）
如果是数字（c）和c.值“0”，那么我将忽略0，因为它们将在以后添加回来
Set rowRange=xSheet.Range（c，c.entireclumn.Cells（1））'设置从单元格到注释顶部单元格的范围
对于copyRng.SpecialCells（xlCellTypeVisible）中的每个q，循环遍历该范围，找到其正上方的帐号，并将其设置为rowSrc
如果仪表（1，q值，“C-”），则_
设置rowSrc=q
下一个问题
设置colSrc=c.EntireRow.Offset（0.Cells（1）”查找与该号码连接的警报
numCol=DestSh.Cells.Find（colSrc.Value，SearchOrder:=xlByRows，SearchDirection:=xlPrevious）。Column'查找列出相同警报的列
numRow=DestSh.Cells.Find（rowSrc.Value，SearchOrder:=xlByColumns，SearchDirection:=xlPrevious）。Row'查找列出相同帐户的行
'设置目的地
Set destng=DestSh.Cells（numRow，numCol）
'复制到目标范围
c、 复制销毁
如果结束
下一个c
如果结束
下一页
退出主题：
应用程序。转到DestSh。单元格（1）
应用
.ScreenUpdate=True
.EnableEvents=True
.Calculation=xlcalculation自动
以
端接头

---

到目前为止，我还没有定义单元格上方的范围以查找帐号。它总是看起来像是B1，这对我来说毫无意义。实际代码要长一点，因为它还生成带有帐号和警报的摘要选项卡。我知道这是一个很长的问题，但我已经花了三天的时间在这个问题上，我想我应该问一个长问题，而不是5个忽略全局的短问题。如果你能提出一个更好的方法来解决这个问题，我也很高兴听到你这么说。

我知道这不是你问题的答案，但你的问题需要先解决，然后才能解决，我需要代码格式来说明我的意思。下面是定义CopyRange的代码。它消除了语法中难以发现的歧义

With xSheet
    R = .Cells(.Rows.Count, 1).End(xlUp).Row            ' observe the period before Rows.Count
    C = .Cells(1, .Columns.Count).End(xlToRight).Column ' observe the period before Columns.Count
    Set CopyRng = .Range(.Cells(1, 1), .Cells(R, C))
End With

For Each CopyCell In CopyRng
    If IsNumeric(CopyCell.Value) And CopyCell.Value <> "0" Then 'I am ignoring 0s since they will be added back later
        With xSheet
            Set RowRng = .Range(.Cells(1, CopyCell.Column), CopyCell) 'set range from cell up to the top cell of the comment
        End With
        For Each q In CopyRng       ' here you are committing logical error:
                                    ' you are already looping through all cells in CopyRng

与xSheet
R=.Cells（.Rows.Count，1）.End（xlUp）.Row'观察Rows.Count之前的句点
C=.Cells（1，.Columns.Count）.End（xlToRight）.Column'观察Columns.Count之前的句点
设置CopyRng=.Range（.Cells（1,1），.Cells（R,C））
以
对于CopyRng中的每个复制单元
如果是numeric（CopyCell.Value）和CopyCell.Value“0”，则“我将忽略0，因为它们将在稍后添加回来。”
用xSheet
Set RowRng=.Range（.Cells（1，CopyCell.Column），CopyCell）设置从单元格到注释顶部单元格的范围
以
对于CopyRng'中的每个q，这里您提交的是逻辑错误：
'您已经在CopyRng中的所有单元格中循环

恐怕我在这里的任务没有什么成功的希望。首先，对我来说已经很晚了。另一方面，如果没有数据进行测试，就不可能找到所有错误。我希望以上内容能给你一点帮助，让你自己继续下去。使用更具描述性的变量名也有助于提高代码的可读性

除非你的问题在早上解决了，否则请确认以下是你的计划或纠正我误解的顺序。同时回答计划中包含的问题

For Each xSheet In ActiveWorkbook.Worksheets
    If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then

        ' Examine each column
          ' starting with columns(1) ??
          ' Take the account number from rows(1)
          ' Check if the account number already exists in DestSh.Columns(1)
            ' which is the first row with data in DestSh ??
          ' IF the account number is not found
            ' add the account number in a new row "R"
          ' ELSE the found row is "R"

          ' Now take each cell below the account number in xSheet
            ' starting in row 2 ????
          ' Search for the value of that cell in DestSh.Rows(1)
          ' IF the value isn't found
            ' add a new column on the right and all it "C"
          ' ELSE the cound column is "C"

          ' In DestSh.Cells(R, C) write what ?????

          ' continue until the end of the xSheet.Column with the account number at the top
        ' then take the next column

ActiveWorkbook.工作表中每个xSheet的

如果InStr（1，xSheet.Name，“ACCOUNT”）和xSheet.Range（“B1”）“无可用摘要”，则
“检查每一列
'从第（1）列开始？'？？
'从第（1）行中获取帐号
'检查DestSh.列（1）中是否已存在帐号
'哪个是DestSh中包含数据的第一行？？
'如果找不到帐号
'将帐号添加到新行“R”
'否则找到的行为“R”
Private Sub CommandButton24_Click()
    ' 24 Aug 2017

    ' Variable naming (throughout the project):
    '   Use Ws for worksheet, Rng for Range
    '   Use R for row, C for column
    '   Use S (or s) for source, T (or t) for target

    Dim Wb As Workbook
    Dim WsS As Worksheet, WsT As Worksheet          ' Source & Target

    Set Wb = ActiveWorkbook                         ' this is different from ThisWorkbook !!
    On Error Resume Next
    Set WsT = Wb.Worksheets("Summary")
    If Err Then
        Set WsT = Wb.Worksheets.Add(Before:=Worksheets(1))
        WsT.Name = "Summary"
    Else
        WsT.Cells.ClearContents                     ' ensure the sheet is blank
    End If
    On Error GoTo 0
    SetAppProps False

    ' Loop through all worksheets:
    ' don't use For .. Each if there are frequent deletions or additions
    ' of worksheets in this workbook. Use Worksheet(Index) instead.
    For Each WsS In Wb.Worksheets
        With WsS
            If StrComp(.Cells(1, "B").Text, "No Summary Available", vbTextCompare) And _
               InStr(1, .Name, "ACCOUNT", vbTextCompare) > 0 Then
                Application.StatusBar = "Processing " & .Name
                If Not CopyToSummary(WsS, WsT) Then
                    MsgBox "An error occurred while processing" & vbCr & _
                           "sheet """ & .Name & """." & vbCr & _
                           "I am abandoning the task.", _
                           vbCritical, "Programm failure"
                    Exit For
                End If
            End If
        End With
    Next WsS

    SetAppProps True
End Sub

Private Function CopyToSummary(WsS As Worksheet, _
                               WsT As Worksheet) As Boolean
    ' 24 Aug 2017
    ' return Not True if an error occurred

    Dim Rs As Long, Cs As Long                      ' source coordinates
    Dim Rt As Long, Ct As Long                      ' target coordinates
    Dim Rl As Long, Cl As Long                      ' last row or column
    Dim AccNum As String                            ' account number
        ' it is critical that AccNum is defined correctly
        ' either as string or as some type of number. What is it?
    Dim Commt As String
    Dim CopyRng As Range

    With WsS
        ' find the last used column in row 2: is that correct ????
        Cl = .Cells(2, .Columns.Count).End(xlToLeft).Column
        For Cs = 1 To Cl                            ' Examine each column
                                                    ' starting with Columns(1) ???
            Rl = .Cells(.Rows.Count, Cs).End(xlUp).Row
            ' CopyRng = Account number and comments below it: (starting from Rows(1))
            Set CopyRng = .Range(.Cells(1, Cs), .Cells(Rl, Cs))
            AccNum = CopyRng.Cells(1).Value         ' AccNum is found in Rows(1) ???
            Rt = SummaryRow(AccNum, WsT)

            ' AccNum will be copied to WsT even if there are no comments
            ' Now take each cell below the account number in WsS starting in row 2
            For Rs = 2 To CopyRng.Cells.Count       ' no blank row below AccNum in WsS
                Commt = CopyRng.Cells(Rs)
                Ct = SummaryColumn(Commt, WsT)

                ' In WsT.Cells(Rt, Ct) write what ?????
            Next Rs
        Next Cs
    End With

    CopyToSummary = True
End Function

Private Sub TestSummaryColumn()

    Dim Commt As String
    Dim WsT As Worksheet

    Commt = "not Something"
    Set WsT = Worksheets("Summary")
    Debug.Print SummaryColumn(Commt, WsT)
End Sub
Private Function SummaryColumn(Commt As String, _
                               WsT As Worksheet) As Long
    ' 24 Aug 2017

    Dim Fun As Long                             ' function return value
    Dim Rng As Range                            ' search range for Commt
    Dim Cl As Long                              ' last column in WsT

    With WsT
        ' hard-programmed: .Rows(1) has comments
        Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' hard-programmed: Cell(A1) must not have a comment occurring in WsS
        Set Rng = .Range(.Cells(1, 1), .Cells(1, Cl))
    End With
    On Error Resume Next
    Fun = Application.Match(Commt, Rng, 0)
        ' Search for the comment in WsT.Rows(1)
    If Err Then
        ' IF the value isn't found
          ' add a new column on the right:
           Fun = Cl + 1
          ' Format WsT.Columns(Fun)
        Err.Clear
    End If
    ' ELSE the cound column is "Fun" (already so)


    SummaryColumn = Fun
End Function

Private Sub TestSummaryRow()

    Dim AccNum As String
    Dim WsT As Worksheet

    AccNum = "016"
    Set WsT = Worksheets("Summary")
    Debug.Print SummaryRow(AccNum, WsT)
End Sub
Private Function SummaryRow(AccNum As String, _
                            WsT As Worksheet) As Long
    ' 24 Aug 2017

    Dim Fun As Long                             ' function return value
    Dim Rng As Range                            ' search range for AccNum
    Dim Rl As Long                              ' last row

    With WsT
        ' hard-programmed: .Columns(1) has account numbers
        Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
        ' hard-programmed: First account number is in Rows(1) - no column captions:
        Set Rng = .Range(.Cells(1, 1), .Cells(Rl, 1))
    End With
    On Error Resume Next
    Fun = Application.Match(AccNum, Rng, 0)
    ' Check if the account number already exists in WsT.Columns(1)
    If Err Then
        ' IF the account number is not found
           Fun = Rl + 1
          ' add the account number in a new row "Fun"
        Err.Clear
    End If
    ' ELSE the found row is "Fun" (already so)

    SummaryRow = Fun
End Function

Private Sub SetAppProps(ByVal AppMode As Boolean)
    ' 24 Aug 2017

    With Application
        .ScreenUpdating = AppMode
        .EnableEvents = AppMode
        .Calculation = Array(xlCalculationManual, xlCalculationAutomatic)(Int(AppMode) + 1)
        .StatusBar = ""
    End With
End Sub