A macro to make a summary sheet

[ADK]

I have an Excel file which has various sheets (departments) which have a
list of drawings associated with that department. I would like to take the
lists from each sheet and make a master summary list of drawings. Sometimes
a department will have more or less drawings per project. The number of rows
in each department vary and can change throughout the project. I would like
a macro that goes to each sheet and within a set maximum range, select those
rows which are NOT empty and copy the values to the summary sheet ...then
the next sheet values would follow on the summary sheet. It would also be
nice if it would insert the department name at the top of each list (that
cell is: A1).

Hopefully I explained that well.

We have another spreadsheet with a macro that does something like that but
have no idea how it works and how to modify it to suit my spreadsheet.

The maximum range is: A386

My sheets are:

General
Arrangement of Equipment DWGS
Structural Steel DWGS
Arrangement of Piping DWGS
Pipe Supports
Isometric Piping Spools
Insulation & Heat Trace Dwgs
Instrumentation Drawings
Electrical Drawings
Shipping and Rigging
Reference Drawings

Here is the code (which is assign to a button) from the sample spreadsheet:

'
' Select a range
'
Sub selectrange()
Dim rowcoord As Single
Dim putcoord As Single
Dim shtnumber As Single
Dim x As Single

Application.CutCopyMode = False
Worksheets("Summary").Activate
Rows("3:750").Select
Selection.Delete Shift:=xlUp
Range("B3").Select
shtnumber = 1
putcoord = 2
Do
For x = 1 To shtnumber
ActiveSheet.Next.Select
Next
If Application.ActiveSheet.Name = "Autocad Colors" Then
Exit Do
End If
rowcoord = 2
Do
If (Range("A1").Offset(rowcoord, 1) = "") And
(Range("A1").Offset(rowcoord + 1, 1) = "") Then
Exit Do
Else
rowcoord = rowcoord + 1
End If
Loop
Range(Range("A1").Offset(1, 1), Range("A1").Offset(rowcoord - 1,
14)).Select
Selection.Copy
Worksheets("Summary").Activate
Do
If (Range("A1").Offset(putcoord, 1) = "") And
(Range("A1").Offset(putcoord + 1, 1) = "") Then
Exit Do
Else
putcoord = putcoord + 1
End If
Loop
putcoord = putcoord + 2
Range("A1").Offset(putcoord, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
shtnumber = shtnumber + 1
Loop
Worksheets("Summary").Activate
For x = 1 To shtnumber
ActiveSheet.Next.Select
Range("B3").Select
Next
Worksheets("Summary").Activate
Range("B3").Select
End Sub

 

[Ron de Bruin]

Hi ADK

Try
http://www.rondebruin.nl/copy2.htm

 

[ADK]

I tried but I receive a Compile Error Sub or function not defined
and it highlights LastRow

Here is what the code is:

Sub Summary()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim shLast As Long
Dim Last As Long

On Error Resume Next
If Len(ActiveWorkbook.Worksheets.Item("Master").Name) = 0 Then
On Error GoTo 0
Application.ScreenUpdating = False
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)

'sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy
DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below to copy
only the values
'or use the PasteSpecial option to paste the format also.


'With sh.Range(sh.Rows(3), sh.Rows(shLast))
'DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
'.Columns.Count).Value = .Value
'End With


sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
Application.CutCopyMode = False
End With

End If
Next
DestSh.Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub

 

[Ron de Bruin]

Hi ADK

Copy the function LastRow also from that webpage into your module

 

[ADK]

also, I can not find in your examples where you can keep it within a
selected range on each sheet (A386). It seems to me that these examples
will copy all rows with data ...which there are rows I wish to omit.

 

[ADK]

Can I send you the xls file?

Hi ADK

Copy the function LastRow also from that webpage into your module

 

[Ron de Bruin]

OK