Help with Mr. Dave Peterson's Code for Consolidating Many Sheets to One

R

Rashid Khan

Hello All,
Following is the macro posted by Mr. Dave Peterson. It works fineOption Explicit
Option Base 0
Sub testme2()
Dim newWks As Worksheet
Dim wks As Worksheet
Dim DestCell As Range
Dim RngToCopy As Range
Dim iCtr As Long
Dim myAddresses As Variant
Dim oRow As Long
'billed, balance, due
myAddresses = Array("a55", "a56", "a57")

Set newWks = Worksheets.Add(after:=Worksheets(Worksheets.Count))

With newWks
.Name = "Cons " & Format(Now, "yyyymmdd_hhmmss")
.Range("a1").Resize(1, 4).Value _
= Array("PartyName", "TotalBilled", "TotalBalance",
"TotalDue")
oRow = 1
End With

For Each wks In ActiveWorkbook.Worksheets
If wks.Name = newWks.Name Then
'do nothing
Else
oRow = oRow + 1
With wks
newWks.Cells(oRow, "A").Value = .Name
For iCtr = LBound(myAddresses) To UBound(myAddresses)
newWks.Cells(oRow, "A").Offset(0, 1 + iCtr).Value
_
= .Range(myAddresses(iCtr)).Value
Next iCtr
End With
End If
Next wks

End Sub
<<<
The macro makes a Consolidated Worksheet (Cons) of all the worksheets. I
need to have the following changes to take place in the consolidated
worksheet
1) Set the ColumnWidth to Autofit
2) Have the Sum (Total) at the bottom for each Column (starting from B
onwards).

Any suggestions please
TIA
Rashid
 
T

Tom Ogilvy

Option Explicit
Option Base 0
Sub testme2()
Dim newWks As Worksheet
Dim wks As Worksheet
Dim DestCell As Range
Dim RngToCopy As Range
Dim iCtr As Long
Dim myAddresses As Variant
Dim rng as Range
Dim oRow As Long
'billed, balance, due
myAddresses = Array("a55", "a56", "a57")

Set newWks = Worksheets.Add(after:=Worksheets(Worksheets.Count))

With newWks
.Name = "Cons " & Format(Now, "yyyymmdd_hhmmss")
.Range("a1").Resize(1, 4).Value _
= Array("PartyName", "TotalBilled", _
"TotalBalance", "TotalDue")
oRow = 1
End With

For Each wks In ActiveWorkbook.Worksheets
If wks.Name = newWks.Name Then
'do nothing
Else
oRow = oRow + 1
With wks
newWks.Cells(oRow, "A").Value = .Name
For iCtr = LBound(myAddresses) To UBound(myAddresses)
newWks.Cells(oRow, "A").Offset(0, 1 + iCtr).Value _
= .Range(myAddresses(iCtr)).Value
Next iCtr
End With
End If
Next wks
for iCtr = 2 to Ubound(MyAddresses) + 2
set rng = newWks.Cells(rows.count,iCtr).end(xlup)(2)
rng.FormulaR1C1 = "=Sum(R2C:R[-1]C)"
Next
newWks.Columns.Autofit
End Sub
 
R

Rashid Khan

Hello Tom,
It works like a charm. U r a great help... as always.
Rashid

Tom Ogilvy said:
Option Explicit
Option Base 0
Sub testme2()
Dim newWks As Worksheet
Dim wks As Worksheet
Dim DestCell As Range
Dim RngToCopy As Range
Dim iCtr As Long
Dim myAddresses As Variant
Dim rng as Range
Dim oRow As Long
'billed, balance, due
myAddresses = Array("a55", "a56", "a57")

Set newWks = Worksheets.Add(after:=Worksheets(Worksheets.Count))

With newWks
.Name = "Cons " & Format(Now, "yyyymmdd_hhmmss")
.Range("a1").Resize(1, 4).Value _
= Array("PartyName", "TotalBilled", _
"TotalBalance", "TotalDue")
oRow = 1
End With

For Each wks In ActiveWorkbook.Worksheets
If wks.Name = newWks.Name Then
'do nothing
Else
oRow = oRow + 1
With wks
newWks.Cells(oRow, "A").Value = .Name
For iCtr = LBound(myAddresses) To UBound(myAddresses)
newWks.Cells(oRow, "A").Offset(0, 1 + iCtr).Value _
= .Range(myAddresses(iCtr)).Value
Next iCtr
End With
End If
Next wks
for iCtr = 2 to Ubound(MyAddresses) + 2
set rng = newWks.Cells(rows.count,iCtr).end(xlup)(2)
rng.FormulaR1C1 = "=Sum(R2C:R[-1]C)"
Next
newWks.Columns.Autofit
End Sub

--
Regards,
Tom Ogilvy

Rashid Khan said:
Hello All,
Following is the macro posted by Mr. Dave Peterson. It works fine
Option Explicit
Option Base 0
Sub testme2()
Dim newWks As Worksheet
Dim wks As Worksheet
Dim DestCell As Range
Dim RngToCopy As Range
Dim iCtr As Long
Dim myAddresses As Variant
Dim oRow As Long
'billed, balance, due
myAddresses = Array("a55", "a56", "a57")

Set newWks = Worksheets.Add(after:=Worksheets(Worksheets.Count))

With newWks
.Name = "Cons " & Format(Now, "yyyymmdd_hhmmss")
.Range("a1").Resize(1, 4).Value _
= Array("PartyName", "TotalBilled", "TotalBalance",
"TotalDue")
oRow = 1
End With

For Each wks In ActiveWorkbook.Worksheets
If wks.Name = newWks.Name Then
'do nothing
Else
oRow = oRow + 1
With wks
newWks.Cells(oRow, "A").Value = .Name
For iCtr = LBound(myAddresses) To UBound(myAddresses)
newWks.Cells(oRow, "A").Offset(0, 1 + iCtr).Value
_
= .Range(myAddresses(iCtr)).Value
Next iCtr
End With
End If
Next wks

End Sub
<<<
The macro makes a Consolidated Worksheet (Cons) of all the worksheets. I
need to have the following changes to take place in the consolidated
worksheet
1) Set the ColumnWidth to Autofit
2) Have the Sum (Total) at the bottom for each Column (starting from B
onwards).

Any suggestions please
TIA
Rashid
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Help with Code to Copy to New Worksheet 2
Coding Help 5
Rename Multiple Sheets - Help with Mr Dave Peterson's Code 2
Locate and Move Specific Cells 2
Help with Mr. Peterson's Code.. Print serially from a Sheet 50
Please help restructure this code 9
Inaccurate count with code 6
Help with Hyperlink...Mr. Dave Peterson's Code 4

Top