Question

我需要找到一种方法将多张表中的数据复制到摘要表中。数据来自的表格看起来像这些（块的数量和大小各不相同）

帐号位于顶部，一侧有不同数量的警报，而且各处都有多个街区。

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

左侧有帐号，顶部有不同的提醒。每张工作表中的每个帐户都在该表中，因此每个工作表都是唯一的。现在，我从工作表中获取数据的计划是遍历每个工作表，并尝试将每个单元格与表格中的警报和帐号匹配，然后插入它。

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

到目前为止，我还没有设法定义单元格上方的范围，以便找到帐号。似乎只是B1对我来说毫无意义。实际代码有点长，因为它还会生成包含帐号和警报的摘要选项卡。我知道这是一个很长的问题，但是我已经在3天的大部分时间里一直在研究它，我想我会问一个很长的问题，而不是5个忽略大局的短问题。如果你能提出一个更好的方法来解决这个问题，我也很高兴听到它。

Answer 1

我知道这不是你问题的答案，但你的问题需要在处理之前刷新，我需要代码格式来表明我的意思。以下是定义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

我担心我在这里的任务没有成功的希望。首先，它对我来说已经很晚了。对于另一个，如果没有要测试的数据，将无法找到所有错误。我希望上面的内容会给你一点帮助，让你自己继续。使用更具描述性的变量名称也有助于提高代码的可读性。

除非您在早上解决问题，否则请确认以下是您的计划或更正我误解的顺序。还要回答计划中包含的问题。

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

Answer 2

我很高兴你的问题得到了解决。与此同时，我一直在根据我昨天指出的工作流程准备另一种方法。它现在是学术性的，但对你来说仍然比对我更有价值，并且太多的工作只是扔掉它:-)。也许你可以使用它的某些部分。

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

代码未完成。以上是作为布局。其中一个不那么明显的失败是CopyToSummary函数的返回值。代码代表它始终返回True。它应编程为在发生错误时跳过最后一行或在这种情况下返回False。

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

2 个答案: