Modify Macro to Paste the Correct Range of Data

[legalhustler]

The macro below combines several source sheets to a report sheet called "Combined." The macro works fairly well, except the value results in column A and B of the "Combined" sheet is returning the wrong range size based on each of the respective source sheets it pastes from. The range size from column A & B should be the same as columns C:H of the "Combined" sheet.

I will first explain where the values of column B of the "Combined" sheet comes from. The values from column B comes from copying the value of cell A4 of each source sheet. To determine how many rows cell A4 should be pasted to the "Combined" sheet, the code should determine the range, (always) starting at A8 to the last row and subtract 3 rows (which are not needed) of each respective source sheet, then pasting them starting from B3 of the "Combined" sheet.

The values from column A of the "Combined" sheet is taking left four characters from the value results of column B (mentioned above), starting at A3. Therefore the range in column A should be the same as column B, respective of each source sheet.

Here is what the code currently is doing. The first source sheet has the value "9800 - Workers Compensation" in cell A4. The data starts from A8:A94 (total of 87 rows), however the "Combined" sheet, pasted the value of cell A4 "9800 - Workers Compensation" from B3:B94 (total of 92 rows) instead of from B3:B89.

The second source sheet has the value "6500 - Claims Account" in cell A4. The data range is from A8:A97 (total of 90 rows), however the "Combined" sheet, pasted the value of cell A4 "6500 - Claims Account" from B95:B189 instead of from B90:B179.

Similarly, column A (starting at A3) of the "Combined" sheet which takes the 4 left characters of column B (starting at B3) has extra rows of data. The "Combined" sheet shows the pasted values for the first source sheet from A3:A94 and from A95:A189 for the second source sheet; however they should be from A3:A89 and A90:A179, for each sheet respectively.

Can someone assist in modifying the macro below to meet the correct requirements mentioned above?

Sub CombineReports()
    Dim sh As Worksheet, nsh As Worksheet, lr As Long, c As Range
    Dim x As Long, nRng As Range

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

    Set nsh = Sheets.Add(before:=Sheets(1))
    nsh.Name = "Combined"

    With nsh
        .Range("A2") = "Account #": .Range("B2") = "Account Name": .Range("C2") = "Fund": .Range("D2") = "Debit": .Range("E2") = "Credit"
        .Range("F2") = "Debit": .Range("G2") = "Credit": .Range("H2") = "Total"
        .Range("D1:E1").Merge
        .Range("D1") = "Pre-Closing"
        .Range("F1:G1").Merge
        .Range("F1") = "Post-Closing"
        .Range("D1:G1").HorizontalAlignment = xlCenter
        .Range("D1:G1").Font.Bold = True
        .Columns("D:H").NumberFormat = "#,##0.00 ;(#,##0.00)"
    End With

    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Combined" Then

            lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
            sh.Range("A8", sh.Cells(lr - 3, 6)).Copy
            nsh.Cells(Rows.Count, "C").End(xlUp)(2).PasteSpecial xlPasteValues
            Application.CutCopyMode = False

            x = sh.Range("A3:A" & sh.Range("A" & Rows.Count).End(xlUp).Row).Rows.Count - 3

            If nsh.Range("B" & Rows.Count).End(xlUp).Row < 3 Then
                nsh.Range("B3").Resize(x).Value = sh.Range("A4").Value
            Else
                nsh.Range("B" & Rows.Count).End(xlUp)(2).Resize(x).Value = sh.Range("A4").Value
            End If

            Set nRng = nsh.Range("B3", nsh.Cells(Rows.Count, "B").End(xlUp))

            For Each c In nRng
                c.Offset(, -1) = Left(c.Value, 4)
            Next
            nRng.Offset(, -1).NumberFormat = "0000"

        End If
    Next

    ActiveWindow.DisplayGridlines = False
    Columns.AutoFit
    Range("A1").Select
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[JackDanIce]

Below is untested and based on your code and comments, maybe test on a copy of your file first, however, replace all of your code with the following:

Sub CombineReports_V1()

    Dim x       As Long
    Dim wksNew  As Worksheet
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set wksNew = FormatNewSheet(Sheets.add(before:=Sheets(1)))
    
    For x = 1 To ThisWorkbook.Worksheets.Count
        If Sheets(x).Name <> wksNew.Name Then Call ProcessSheet(Sheets(x), wksNew)
    Next x
    
    With wksNew
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        .Cells(3, 1).Resize(x).NumberFormat = "0000"
    End With
    
    Set wksNew = Nothing
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub



Private Function FormatNewSheet(ByRef wks As Worksheet) As Worksheet


    With wks
        .Name = "Combined"
        .Range("A2") = "Account #": .Range("B2") = "Account Name": .Range("C2") = "Fund": .Range("D2") = "Debit": .Range("E2") = "Credit"
        .Range("F2") = "Debit"
        .Range("G2") = "Credit"
        .Range("H2") = "Total"
        .Range("D1:E1").Merge
        .Range("D1") = "Pre-Closing"
        .Range("F1:G1").Merge
        .Range("F1") = "Post-Closing"
        With .Range("D1:G1")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        End With
        .Columns("D:H").NumberFormat = "#,##0.00 ;(#,##0.00)"
    End With
    
    Set FormatNewSheet = wks
    
End Function



Private Sub ProcessSheet(ByRef wks As Worksheet, ByRef destWks As Worksheet)
    
    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    
    With wks
        x = .Cells.find("*", .Cells(1, 1), xlValues, xlPart, xlByRows, xlPrevious).row - 3
        arr = .Cells(8, 1).Resize(x, 6).Value
        x = destWks.Cells(destWks.Rows.Count, 3).End(xlUp).row
        x = Application.Max(x, 2)
        destWks.Cells(x, 3).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    Erase arr
    
    With destWks
        y = .Cells(.Rows.Count, 1).End(xlUp).row
        .Cells(Application.Max(3, y + 2), 2).Resize(x).Value = wks.Cells(4, 1).Value
        y = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(3, 2).Resize(y - 2).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            arr(x, 1) = Left$(arr(x, 1), 4)
        Next x
        
        .Cells(3, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    
    Erase arr
    End With
        
End Sub

 

[legalhustler]

Below is untested and based on your code and comments, maybe test on a copy of your file first, however, replace all of your code with the following:

Sub CombineReports_V1()

    Dim x       As Long
    Dim wksNew  As Worksheet
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set wksNew = FormatNewSheet(Sheets.add(before:=Sheets(1)))
    
    For x = 1 To ThisWorkbook.Worksheets.Count
        If Sheets(x).Name <> wksNew.Name Then Call ProcessSheet(Sheets(x), wksNew)
    Next x
    
    With wksNew
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        .Cells(3, 1).Resize(x).NumberFormat = "0000"
    End With
    
    Set wksNew = Nothing
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub



Private Function FormatNewSheet(ByRef wks As Worksheet) As Worksheet


    With wks
        .Name = "Combined"
        .Range("A2") = "Account #": .Range("B2") = "Account Name": .Range("C2") = "Fund": .Range("D2") = "Debit": .Range("E2") = "Credit"
        .Range("F2") = "Debit"
        .Range("G2") = "Credit"
        .Range("H2") = "Total"
        .Range("D1:E1").Merge
        .Range("D1") = "Pre-Closing"
        .Range("F1:G1").Merge
        .Range("F1") = "Post-Closing"
        With .Range("D1:G1")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        End With
        .Columns("D:H").NumberFormat = "#,##0.00 ;(#,##0.00)"
    End With
    
    Set FormatNewSheet = wks
    
End Function



Private Sub ProcessSheet(ByRef wks As Worksheet, ByRef destWks As Worksheet)
    
    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    
    With wks
        x = .Cells.find("*", .Cells(1, 1), xlValues, xlPart, xlByRows, xlPrevious).row - 3
        arr = .Cells(8, 1).Resize(x, 6).Value
        x = destWks.Cells(destWks.Rows.Count, 3).End(xlUp).row
        x = Application.Max(x, 2)
        destWks.Cells(x, 3).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    Erase arr
    
    With destWks
        y = .Cells(.Rows.Count, 1).End(xlUp).row
        .Cells(Application.Max(3, y + 2), 2).Resize(x).Value = wks.Cells(4, 1).Value
        y = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(3, 2).Resize(y - 2).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            arr(x, 1) = Left$(arr(x, 1), 4)
        Next x
        
        .Cells(3, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    
    Erase arr
    End With
        
End Sub

Your code screwed up the "Combined" report further. It removed the headers, included the last three rows of each source sheet that I don't need, only pasted the first source sheet, column B is pasted from A4:A5 and column A is pasted from B4:B5. See the bold fonts in my OP to see the range where column A & B should be pasted for the first source sheet, second source sheet etc. Remember I have many source sheets, not just two.

The original code I provided determined the last source sheet and everything combined perfectly from column C:H in the "Combined" sheet, the only issue is the range size for column A & B which it did not paste correctly.

 

[JackDanIce]

Your request was to modify the code, your code adds a NEW sheet and then proceeds to apply various values and formatting to it.

Set nsh = Sheets.add(before:=Sheets(1))
nsh.Name = "Combined"

I did not change anything for the formatting to the new sheet in my suggested code, that your code does not already do.

There was a suggestion to test on a copy of your workbook first as well. I can only base suggestions on what code you provide and your comments, since I cannot see your screen or file.

Perhaps someone else can offer a working solution based on your request without screwing up your "Combined" report further.

 

[legalhustler]

Your request was to modify the code, your code adds a NEW sheet and then proceeds to apply various values and formatting to it.

I did not change anything for the formatting to the new sheet in my suggested code, that your code does not already do.

There was a suggestion to test on a copy of your workbook first as well. I can only base suggestions on what code you provide and your comments, since I cannot see your screen or file.

Perhaps someone else can offer a working solution based on your request without screwing up your "Combined" report further.

First, I just like to apologize for boldly saying your code "screwed" the Combined sheet, your code didn't screw anything it just didn't provide the results that I was looking. My current code (in post #1) does everything right except the results it returns to column A & B of the "Combined" sheet are not the correct size range as column C:H for each respective source sheet. I provided instructions on how column A & B are determined in my post #1. If you have any questions about that then let me know.

Thanks - hope you or someone can help me resolve this.

 

[legalhustler]

I have attached a sample of my data in the link below. You will note in the "Combined" sheet that column A & B have yellow highlights to show that the range does not match with what is in Report1, Report2 and Report3. Please refer to my original post to see how the range for column A & B are determined.

If someone can help address in fixing my issue that would be awesome.

Dropbox - Sample Data.xlsm

 

[legalhustler]

Can anyone look at my sample data (see link in post #6 ) and help fix my macro so that the "Combined" sheet returns the same data range for column A & B as "Report1", "Report2", and "Report3" sheet.

 

[legalhustler]

Anyone?

 

[legalhustler]

I figured it on my own.

Instead of subtracting 3 at the end all I had to do was subtract 8 from this line of my code:

x = sh.Range("A3:A" & sh.Range("A" & Rows.Count).End(xlUp).Row).Rows.Count - 8

I wish I could give myself a thumbs up :P