Modify sub to include sheetname in new col

[Max]

Looking for help to modify the sub below (from Don Guillett), so that it
also prints the source sheetnames in a new col to the right of the appended
data in "Summary". Thanks.

Sub newsummarysheet()
'Don Guillett
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In ActiveWorkbook.Sheets
dlr = Cells(Rows.Count, "a").End(xlUp).Row + 1
slr = ws.Cells(Rows.Count, "a").End(xlUp).Row
If ws.Name <> "Summary" Then
ws.Rows("1:" & slr).Copy Cells(dlr, 1)
End If
Next ws
End Sub

 

[Mike H]

Max,

This writes the shhet name at each change of source data

Sub newsummarysheet()
'Don Guillett
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In ActiveWorkbook.Sheets
dlr = Cells(Rows.Count, "a").End(xlUp).Row + 1
slr = ws.Cells(Rows.Count, "a").End(xlUp).Row

If ws.Name <> "Summary" Then
ws.Rows("1:" & slr).Copy Cells(dlr, 1)
Cells(dlr, 1).Offset(, 1) = ws.Name
End If
Next ws
End Sub

Mike

 

[Mike H]

Ah,

Just noticed this is copying the entire row not kust column A so try this
instead

Sub newsummarysheet()
For Each ws In ActiveWorkbook.Sheets
X = WorksheetFunction.Max(X, ws.UsedRange.Columns.Count)
Next
'Don Guillett
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In ActiveWorkbook.Sheets
dlr = Cells(Rows.Count, "a").End(xlUp).Row + 1
slr = ws.Cells(Rows.Count, "a").End(xlUp).Row

If ws.Name <> "Summary" Then
ws.Rows("1:" & slr).Copy Cells(dlr, 1)

Cells(dlr, 1).Offset(, X) = ws.Name
End If
Next ws
End Sub

Mike

 

[royUK]

This seems to work, I've added a check whether there is already a shee
named "Summary", you can either delete an existing one & add a new on
if required.


Code
-------------------

Sub newsummarysheet()
'Don Guillett
Dim col As Long
If Not wsExists("Summary") Then
Sheets.Add
ActiveSheet.Name = "Summary"
End If
With ActiveSheet
For Each ws In ActiveWorkbook.Sheets
dlr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
slr = ws.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Name <> "Summary" Then
col = ws.UsedRange.Columns.Count + 1
ws.Rows("1:" & slr).Copy .Cells(dlr, 1)
.Range(.Cells(dlr, col), .Cells(ActiveSheet.UsedRange.Rows.Count + 1, col)).Value = ws.Name
End If
Next ws
End With
End Sub

Function wsExists(wksName As String) As Boolean
On Error Resume Next
wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
On Error GoTo 0
End Functio

 

[Max]

Mike, thanks. Could I have it tweaked a little further?
Sheetnames to print down to the last row instead of just the 1st row, and
all sheetname prints to be in text. The latter as I don't want Excel to
convert any sheetnames such as: January 2008 automatically into real dates.
Thanks

Max

 

[Max]

Thanks, Roy. It works fine. One tweak request, to have all sheetname prints
to be in text. As I don't want Excel to convert any sheetnames such as:
January 2008 automatically into real dates. Muchas Gracias`

Max

 

[Mike H]

Try this

Sub newsummarysheet()
For Each ws In ActiveWorkbook.Sheets
x = WorksheetFunction.Max(x, ws.UsedRange.Columns.Count)
Next
'Don Guillett
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In ActiveWorkbook.Sheets
dlr = Cells(Rows.Count, "a").End(xlUp).Row + 1
slr = ws.Cells(Rows.Count, "a").End(xlUp).Row

If ws.Name <> "Summary" Then
ws.Rows("1:" & slr).Copy Cells(dlr, 1)

Cells(dlr, 1).Offset(, x) = ws.Name
End If
Next ws
lastrow = Sheets("Summary").UsedRange.Rows.Count
For b = 2 To lastrow
Cells(b, x + 1).NumberFormat = "@"
If Cells(b, x + 1).Offset(1, 0).Value = "" Then
Cells(b, x + 1).Offset(1, 0).Value = Cells(b, x + 1).Value
End If
Next
End Sub

Mike

 

[Max]

Mike,

The printdown's fine but the sheetnames are still getting converted into
date serial nums?, eg sheetname: "January 2008" prints now as: 39448,
"February 2008" as: 39479. I need it simply as text: January 2008, February
2008. Thanks for further insights.

Max

 

[Mike H]

Hi,

Try this

Sub newsummarysheet()
For Each ws In ActiveWorkbook.Sheets
x = WorksheetFunction.Max(x, ws.UsedRange.Columns.Count)
Next
'Don Guillett
Sheets.Add
ActiveSheet.Name = "Summary"
For Each ws In ActiveWorkbook.Sheets
dlr = Cells(Rows.Count, "a").End(xlUp).Row + 1
slr = ws.Cells(Rows.Count, "a").End(xlUp).Row

If ws.Name <> "Summary" Then
ws.Rows("1:" & slr).Copy Cells(dlr, 1)

With Cells(dlr, 1).Offset(, x)
.NumberFormat = "@"
.Value = ws.Name
End With
End If
Next ws
lastrow = Sheets("Summary").UsedRange.Rows.Count
For b = 2 To lastrow
Cells(b, x + 1).Offset(1, 0).NumberFormat = "@"
If Cells(b, x + 1).Offset(1, 0).Value = "" Then
Cells(b, x + 1).Offset(1, 0).Value = Cells(b, x + 1).Value
End If
Next
End Sub


Mike

 

[Max]

Wonderful, Mike. Works great.
Many thanks

Max

 

[Mike H]

Glad I could help