Consolidate Total From Multiple Worksheets to Main Worksheet

[MariaJohnson88]

Hi All,

I have multiple sheets with the exact same table and a total in the last row of column F
I am looking for VBA code that will assist me in taking the total from column F in each worksheet and placing it in column C on the Main Sheet (Sheet 1).

I can post the Code I already have but it is very wrong

Public Sub CombineDataFromAllSheets()

Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long

'Notes: "Src" is short for "Source", "Dst" is short for "Destination"

'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Table of Content")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!

'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 3)

'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets

'Make sure we skip the "Import" destination sheet!
If wksSrc.Name <> "Table of Content" Then

'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)

'Store the source data then copy it to the destination range
With wksSrc

Public Sub CombineDataFromAllSheets()

Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long

'Notes: "Src" is short for "Source", "Dst" is short for "Destination"

'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Table of Content")
lngDstLastRow = LastOccupiedRowNum(wksDst) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(wksDst) '<~ defined below (and in Toolbelt)!

'Set the initial destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 3)

'Loop through all sheets
For Each wksSrc In ThisWorkbook.Worksheets

'Make sure we skip the "Import" destination sheet!
If wksSrc.Name <> "Table of Content" Then

'Identify the last occupied row on this sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrc)

'Store the source data then copy it to the destination range
With wksSrc
Set rngSrc = .Range("F23")
rngSrc.Copy Destination:=rngDst
End With

'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)

End If

Next wksSrc

End Sub

rngSrc.Copy Destination:=rngDst
End With

'Redefine the destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)

End If

Next wksSrc

End Sub

 

[bobaol]

assumes you have sheet1 to sheet7, where sheet1 is needed for column C, and sheet2 to sheet7 has totals in column F. cheers!
Sub Macro1()

'''go to your sheet where it contain the number in column F,
'''go from bottom up, not top down
Sheets("Sheet7").Select
Application.Goto Reference:="R999999C6"
Selection.End(xlUp).Select
Selection.Copy

'''go to sheet for column C, go from bottom up, paste
Sheets("Sheet1").Select
Application.Goto Reference:="R999999C3"
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False



'''go to your sheet where it contain the number in column F,
'''go from bottom up, not top down
Sheets("Sheet6").Select
Application.Goto Reference:="R999999C6"
Selection.End(xlUp).Select
Selection.Copy

'''go to sheet for column C, go from bottom up, paste
Sheets("Sheet1").Select
Application.Goto Reference:="R999999C3"
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False




'''go to your sheet where it contain the number in column F,
'''go from bottom up, not top down
Sheets("Sheet5").Select
Application.Goto Reference:="R999999C6"
Selection.End(xlUp).Select
Selection.Copy

'''go to sheet for column C, go from bottom up, paste
Sheets("Sheet1").Select
Application.Goto Reference:="R999999C3"
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False




'''go to your sheet where it contain the number in column F,
'''go from bottom up, not top down
Sheets("Sheet4").Select
Application.Goto Reference:="R999999C6"
Selection.End(xlUp).Select
Selection.Copy

'''go to sheet for column C, go from bottom up, paste
Sheets("Sheet1").Select
Application.Goto Reference:="R999999C3"
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False



'''go to your sheet where it contain the number in column F,
'''go from bottom up, not top down
Sheets("Sheet3").Select
Application.Goto Reference:="R999999C6"
Selection.End(xlUp).Select
Selection.Copy

'''go to sheet for column C, go from bottom up, paste
Sheets("Sheet1").Select
Application.Goto Reference:="R999999C3"
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False



'''go to your sheet where it contain the number in column F,
'''go from bottom up, not top down
Sheets("Sheet2").Select
Application.Goto Reference:="R999999C6"
Selection.End(xlUp).Select
Selection.Copy

'''go to sheet for column C, go from bottom up, paste
Sheets("Sheet1").Select
Application.Goto Reference:="R999999C3"
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False



End Sub

 

[MariaJohnson88]

Is this supposed to be a joke reply?
I have 70 sheets

 

[bobaol]

no, not a joke reply. you can manually change all 70 sheets. still be faster than doing it manually. that's what i would do. cheers!

 

[bobaol]

on second thought, try these two, so you don't have to hard-define the sheets. macro6 is for all within one workbook. macro7 is for two workbooks. i personally like macro7 better, but you need two workbooks in order for macro7 to work. hope this helps. cheers!

Sub Macro6_f_to_c_in_one_workbook_()
'assume one workbook, 71 sheets, sheet1 is for column C, sheets2 to 71 are for column F

'move sheet1 to the very end
    Sheets("Sheet1").Select
    Sheets("Sheet1").Move After:=Sheets(71)
'''now, sheet1 is at the very most right of the workbook

For i = 1 To 70
    Sheets("Sheet1").Select
    Application.Goto Reference:="R1C1"
''go previous sheet
    ActiveSheet.Previous.Select
    Application.Goto Reference:="R999999C6"
    Selection.End(xlUp).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Application.Goto Reference:="R999999C3"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Previous.Select
''do not use hard-coded names, use activesheet
''    Sheets("Sheet2").Select
    ActiveSheet.Select
   
''move it to the right of sheet1,so that this sheet is no longer the previous sheet
    ActiveSheet.Move After:=Sheets(71)
Next

'move sheet1 back to the very end
    Sheets("Sheet1").Select
    Sheets("Sheet1").Move After:=Sheets(71)
'''now, sheet1 is at the very most right of the workbook

End Sub



Sub Macro7_copy_f_to_c_1()
'''assumes two workbooks, one named columnC, and one named columnF
    Windows("columnC.xlsx").Activate
    Application.Goto Reference:="R1C1"
'
''assume 70 sheets in columnF
''go to most left sheet
On Error Resume Next
For i = 1 To 70
    Windows("columnF.xlsx").Activate
    Application.Goto Reference:="R1C1"
    ActiveSheet.Previous.Select
Next
    Application.Run "Macro8_copy_f_to_c_2"
End Sub

Sub Macro8_copy_f_to_c_2()
For i = 1 To 70
    Windows("columnC.xlsx").Activate
    Application.Goto Reference:="R1C1"
   
    Windows("columnF.xlsx").Activate
    Application.Goto Reference:="R999999C6"
    Selection.End(xlUp).Select
    Selection.Copy
    Windows("columnC.xlsx").Activate
    Application.Goto Reference:="R999999C3"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Windows("columnF.xlsx").Activate
    Application.CutCopyMode = False
    Calculate
    ActiveSheet.Next.Select
    Windows("columnC.xlsx").Activate
    Application.Goto Reference:="R1C1"
Next
End Sub

 

[Fluff]

@bobaol when posting code please use code tags. How to Post Your VBA Code
I have added them for you this time.

 

[Alex Blakenburg]

@MariaJohnson88 - assuming you added the comments in the code, I have tried to keep what I could.
See if this works for you.

Sub GetTotalFromAllSheets()

    Dim wksSrc As Worksheet, wksDst As Worksheet
    Dim ColSrc As Long, lastRowSrc As Long, nextRowDst As Long, ColDst As Long
    
    Application.ScreenUpdating = False
    
    'Notes: "Src" is short for "Source", "Dst" is short for "Destination"
    
    'Set references up-front
    Set wksDst = ThisWorkbook.Worksheets("Table of Content")
    ColDst = 3                  ' Column C
    nextRowDst = wksDst.Cells(Rows.Count, ColDst).End(xlUp).Row + 1
    
    ' Source Column
    ColSrc = 6                  ' Column F
    
    'Loop through all sheets
    For Each wksSrc In ThisWorkbook.Worksheets
    
        'Make sure we skip the "Import" destination sheet!
        If wksSrc.Name <> "Table of Content" Then
            'Identify the last occupied row on this sheet
            lastRowSrc = wksSrc.Cells(Rows.Count, ColSrc).End(xlUp).Row
            'Transfer Total to Destination sheet
            wksDst.Cells(nextRowDst, ColDst) = wksSrc.Cells(lastRowSrc, ColSrc)
            'Increment destination next row
            nextRowDst = nextRowDst + 1
        End If
    Next wksSrc
    
    Application.ScreenUpdating = True
End Sub