Data summary - Macro changes !!!

[ferocious12]

Hi,

I have the following code. I have worksheets in almost same format except for a month where a new column is added.

- I am using the following macro to copy each column of data from each worksheet in the workbook starting at column D into a newly created summary worksheet
- I have just tried it for couple of columns in the code but not getting the columns copied over for all the worksheets.

Can you please help me to tweak this so this copy same column from all worksheets in the workbook and stack these beside each other so column D from sheet1 should be pasted beside column D from Sheet2

Sub Create_Summary()
  
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Summary").Delete
    Application.DisplayAlerts = True
    n = Application.Worksheets.Count
    Sheets.Add.Name = "Summary"
    Sheets("Summary").Move after:=Worksheets(Worksheets.Count)
  
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> "Summary" And sh.Name <> Sheets(n).Name Then
            Set col = Columns(Columns.Count).End(xlToLeft)
            sh.Range("D:D").Copy Destination:=Sheets("Summary").Range(col, col).Offset(0, 1)
        End If
    Next sh
    Range("A:B").Insert Shift:=xlToRight
    Sheets(n).Select
    Range("F:F").Copy Destination:=Sheets("Summary").Range("A:A")
  
    
End Sub

I have also attached a sample worksheet containing just two months data:

https://dl.dropboxusercontent.com/u/10995251/Data summary.xlsm

Many thanks !!
Sophia

 

[Hui]

Try the following changes:

Sub Create_Summary()
  Dim Col As Range
  Dim n As Integer
  Dim sh As Worksheet
   
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Summary").Delete
  Application.DisplayAlerts = True
  n = Application.Worksheets.Count
  Sheets.Add.Name = "Summary"
  Sheets("Summary").Move after:=Worksheets(Worksheets.Count)
   
  For Each sh In ActiveWorkbook.Worksheets
  If sh.Name <> "Summary" Then
  Set Col = Sheets("Summary").Cells(5, Columns.Count).End(xlToLeft)
  sh.Range("D:D").Copy Destination:=Sheets("Summary").Range(Col.Address).Offset(-4, 1)
  End If
  Next sh
   
  'Range("A:B").Insert Shift:=xlToRight
  'Sheets(n).Select
  'Range("F:F").Copy Destination:=Sheets("Summary").Range("A:A")
   
   
End Sub

 

[ferocious12]

Awesome Hui. Thank you !!

One more tweak I need to stack more columns next to each other from all the worksheets similar to column D. So the Summary worksheet will have all 2 column Ds stacked together, 2 column Es stacked together & so on