Richard
The 3 macros below do what you want. The first macro is a sheet
macro and must be placed in the sheet module for the "Summary" sheet. When
this macro fires, it will call the other 2 macros. Note that this macro
will fire every time you select the "Summary" sheet. Every time. To access
the "Summary" sheet module, right-click on the "Summary" sheet tab, select
View Code. Paste the first macro into that module. You may find it
somewhat of a nuisance for this macro to fire (and set off the other two)
every time you select the Summary sheet while you are setting up your file.
To prevent this macro from firing, access the Summary sheet module and
remark out all 3 lines of code.
The other two macros go in a standard module.
When you select the "Summary" sheet, the following will take place:
The used range of the "Summary" sheet will be cleared.
The code will figure out which sheet is for the current month (you must have
12 sheets named Jan, Feb, Mar, etc).
The data in this month's sheet will be copied to the "Summary" sheet as we
said before.
If Columns A:B of the "Summary" sheet (used range) exceeds row 30, the code
will snake the data into neighboring columns.
Note that the code will not insert a blank column between the snaked
columns. I didn't know if you wanted that or not. Come back if you want
that.
If you are unsure of where to put what macros, email me and I'll
send you a small file that has everything placed properly. My email address
is (e-mail address removed). Remove the "nop" from this address. HTH Otto
Private Sub Worksheet_Activate()
Call GetSummary
End Sub
Sub GetSummary()
Dim RngColB As Range
Dim i As Range
Dim Dest As Range
Application.ScreenUpdating = False
ActiveSheet.UsedRange.ClearContents
Set Dest = Range("A1")
With Sheets(Format(Date, "mmm"))
Set RngColB = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
For Each i In RngColB
If IsEmpty(i) Then GoTo NextCell
Dest.Value = i.Row
Dest.Offset(, 1).Value = i.Value
Set Dest = Dest.Offset(1)
NextCell:
Next i
End With
Call SnakeSum
Application.ScreenUpdating = True
MsgBox "Summary is complete."
End Sub
Sub SnakeSum()
Dim HowMany As Long
Dim RngCopy As Range
Dim Dest As Range
HowMany = 30
If Range("A" & Rows.Count).End(xlUp).Row <= HowMany Then Exit Sub
Set Dest = Range("C1")
Set RngCopy = Cells(1, 1)
Do
RngCopy.Resize(HowMany, 2).Copy Dest
Set RngCopy = RngCopy.Offset(HowMany)
Set Dest = Dest.Offset(, 2)
Loop Until IsEmpty(RngCopy.Value)
Columns("A:B").Delete
End Sub