Matching and copying cells into a summary worksheet / VBA

Question

I need to find a way to copy data from multiple sheets into a summary sheet. The sheets where the data is coming from all look like these (number and size of block varies)

With the account numbers in a line on top and a varying number of different alerts on the side and multiple blocks everywhere.

It is my goal to copy and paste into this table:

Which has the account numbers on the left and the different alerts on top. Every Account in every sheet is in that table and so is every alert (uniquely). Now my plan to get the data from the sheets was to iterated through every sheet, and try to match each cell with the alert and account number in the table and then insert it.

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

So far I have not managed to define the range above the cell in order to find the account number. It always seems to just be B1 which makes no sense to me at all. The actual code is a bit longer since it also generates the summary tab with the account numbers and the alerts. I know this is a very long question but I have been working on it for the better part of 3 days and I figured I'd ask one long question instead of 5 more short ones that ignore the big picture. If you can propose a better way of solving this issue I am also very happy to hear it.

Answer 1

I'm glad you got your problem solved. Meanwhile I had been preparing another approach based on the workflow I indicated yesterday. It's academic now but still of more value to you than to me, and too much work to just throw it away :-). Perhaps you can use some parts of it.

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

The code isn't finished. The above was intended as a layout. One of the less obvious lose ends is the return value of the CopyToSummary function. As the code stands it always returns True. It should be programmed to skip the last line if an error occurs or return False in such an event.

Answer 2

I know this isn't an answer to your problem, but your problem needs to be flushed out before it can be dealt with, and I need the code formatting to show what I mean. Here is code to define your CopyRange. It eliminates ambiguities hard to find in your syntax.

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

I'm afraid my task here has little hope of success. For one thing it's getting very late for me. For another it will be impossible to find all errors without data to test on. I hope the above will give you a little help to continue on your own. Using more descriptive variable names will also help make your code more readable.

Unless you have your problem solved by morning, please confirm that the following is your plan or correct the sequence where I misunderstood. Also answer the questions the plan contains.

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