[HELP] Merging all the details of the work book in one sheet.

[misterewan]

Good Morning..Im kinda new here.Im just wondering. is there a way on how to merge only the details of each sheet of the workbook in only one sheet? I got this code:


Option Explicit

Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

which only gets the heading if it is only a single line. the problem is that my sheet got MERGED cells and also some sheet got 2 tables with the same headings..It really makes me sick :banghead:..

I will attached my file for you guys to see what you can do with it..

Any help would be sincerely appreciated. Thanks!

[p45cal]

This shouldn't be too difficult, but needs some clarification from you on "only the details of each sheet", for example:

Some tables have the likes of 'CS PIPING < 48 INCH' early on in the table, some don't.
Some tables have a Grand Total line, some don't (where there are 2 tables on a sheet).
There's a CWP no. and a drawing no. above many tables (often rows 11 and 12) - do these need to be included?
There are also lines beginning 'Project', 'Location' and 'Owner' above the tables, are they wanted?

Be very precise about just which rows you want copying over in each case - as if you're explaining to an idiot what you want copying.

So far I've been successful at identifying each table by looking for 'Item No.' or 'Project' in the first column in each sheet.

[misterewan]

Thank you for your reply..

1. All of it are CS Piping >42 Inch even the one in below so it needs to be copied once.

2. The 2nd table is the Grand Total of those 2 tables (If the sheet have 2 tables)

3. CWP no. must be copied once because its all the same. Drawing no. should be copied in another column(created column after "remarks") with regards to its items. Also the same with Revision numbers [Rev.0, Rev.1/ not the small Rev2] (Created column after the "Drawing No." column was created) "..for this two I am still formulating/looking for a code that will do it but if you can help me also it will be much appreciated.."

4. Those lines are not too important so you may leave that.

Thank you again for spending time to help a newbie like me..Im looking forward for your solution..

[p45cal]

As a starter for 10, try this (because it currently uses 'ThisWorkbook' in the code, it should be in a code module of the workbook it works on - we can change that later if necessary):
Sub DoTheSummary()
Set NewSheet = ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
NewSheet.Name = "MySummary " & Format(Now(), "hh_mm_ss")
DestRow = 1
HeadersCopied = False
For Each sht In ThisWorkbook.Sheets
lastcolumn = sht.UsedRange.Columns.Count
If Left(sht.Name, 9) <> "MySummary" Then
firstrow = Empty: lastrow = Empty
Set xxx = sht.Columns(1).Find(What:="Project ", LookIn:=xlFormulas, lookat:=xlPart, searchdirection:=xlNext)
If Not xxx Is Nothing Then firstrow = xxx.Row
Set xxx = sht.Columns(2).Find("GRAND TOTAL ", LookIn:=xlFormulas, After:=sht.Columns(2).Cells(sht.Rows.Count), lookat:=xlPart, searchdirection:=xlPrevious)
If Not xxx Is Nothing Then lastrow = xxx.Row
If Not HeadersCopied Then
Set xxx = sht.Columns(1).Find(What:="ITEM No.", LookIn:=xlFormulas, lookat:=xlWhole, searchdirection:=xlNext)
If Not xxx Is Nothing Then
CopyTheRow xxx.Resize(, lastcolumn), NewSheet, DestRow
HeadersCopied = True
End If
End If
If Not (lastrow = Empty Or firstrow = Empty) Then
Set RangeToProcess = Range(sht.Cells(firstrow, 1), sht.Cells(lastrow, lastcolumn))
For Each rw In RangeToProcess.Rows
If Not (rw.Cells(1) = Empty And rw.Cells(2) = Empty) Then
Select Case True
Case Left(rw.Cells(2).Value, 9) = "CS PIPING"
If CSPipingValue <> rw.Cells(2).Value Then
CSPipingValue = rw.Cells(2).Value
CopyTheRow rw, NewSheet, DestRow
End If
Case Left(rw.Cells(1).Value, 3) = "CWP"
If CWPNo <> rw.Cells(1).Value Then
CWPNo = rw.Cells(1).Value
CopyTheRow rw, NewSheet, DestRow
End If
Case Left(rw.Cells(2).Value, 8) = "Line No."
CopyTheRow rw, NewSheet, DestRow
Case InStr(rw.Cells(1).Value, "Project ") = 1
Case InStr(rw.Cells(1).Value, "Location ") = 1
Case InStr(rw.Cells(1).Value, "Owner ") = 1
Case InStr(rw.Cells(1).Value, "PIPING WORKS COST SUMMARY PER ISOMETRIC DRAWINGS") = 1
Case InStr(rw.Cells(1).Value, "ITEM No.") = 1
Case Else
CopyTheRow rw, NewSheet, DestRow
End Select
End If
Next rw
End If
End If
Next sht
NewSheet.Activate
End Sub
Sub CopyTheRow(rw, NewSheet, DestRow)
NewSheet.Cells(DestRow, 1).Resize(, rw.Columns.Count) = rw.Value
If Left(rw.Cells(2), 5) = "GRAND" Then
NewSheet.Cells(DestRow, 1).Resize(, rw.Columns.Count).Borders(xlEdgeBottom).Weight = xlThick
End If
DestRow = DestRow + 1
End Sub We'll add code to deal with Drawing No. etc. if the above is more or less going in the right direction.
The code's a bit rough round the edges at the moment - it could do with streamlining after its functionality is right.

Any jobs going over there? :content:

[misterewan]

Wow Thanks!!this works perfectly..I'm still looking forward for the addition of the columns.

atm,there are still no projects that's because of the crisis but they say there will be project at mid of 2010.

[p45cal]

Sub DoTheSummary()
Application.ScreenUpdating = False
Set NewSheet = ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
NewSheet.Name = "MySummary " & Format(Now(), "hh_mm_ss")
DestRow = 1
HeadersCopied = False
For Each sht In ThisWorkbook.Sheets
lastcolumn = sht.UsedRange.Columns.Count
If Left(sht.Name, 9) <> "MySummary" Then
firstrow = Empty: lastrow = Empty
Set xxx = sht.Columns(1).Find(What:="Project ", LookIn:=xlFormulas, lookat:=xlPart, searchdirection:=xlNext)
If Not xxx Is Nothing Then firstrow = xxx.Row
Set xxx = sht.Columns(2).Find("GRAND TOTAL ", LookIn:=xlFormulas, After:=sht.Columns(2).Cells(sht.Rows.Count), lookat:=xlPart, searchdirection:=xlPrevious)
If Not xxx Is Nothing Then lastrow = xxx.Row
If Not HeadersCopied Then
Set xxx = sht.Columns(1).Find(What:="ITEM No.", LookIn:=xlFormulas, lookat:=xlWhole, searchdirection:=xlNext)
If Not xxx Is Nothing Then
NewSheet.Cells(DestRow, 1).Resize(2, lastcolumn + 1).Font.Bold = True
NewSheet.Cells(DestRow, 1).Resize(1, lastcolumn + 1).Offset(1).Borders(xlEdgeBottom).Weight = xlThin
NewSheet.Cells(DestRow, "M").Value = "DRAWING NO."
CopyTheRow xxx.Resize(2, lastcolumn), NewSheet, DestRow
HeadersCopied = True
End If
End If
If Not (lastrow = Empty Or firstrow = Empty) Then
Set RangeToProcess = Range(sht.Cells(firstrow, 1), sht.Cells(lastrow, lastcolumn))
For Each rw In RangeToProcess.Rows
If Not (rw.Cells(1) = Empty And rw.Cells(2) = Empty) Then
Select Case True
Case Left(rw.Cells(2).Value, 9) = "CS PIPING"
If CSPipingValue <> rw.Cells(2).Value Then
CSPipingValue = rw.Cells(2).Value
CopyTheRow rw, NewSheet, DestRow
End If
Case Left(rw.Cells(1).Value, 3) = "CWP"
If CWPNo <> rw.Cells(1).Value Then
CWPNo = rw.Cells(1).Value
CopyTheRow rw, NewSheet, DestRow
End If
Case Left(rw.Cells(2).Value, 8) = "Line No."
CopyTheRow rw, NewSheet, DestRow
Case InStr(rw.Cells(1).Value, "Project ") = 1
Case InStr(rw.Cells(1).Value, "Location ") = 1
Case InStr(rw.Cells(1).Value, "Owner ") = 1
Case InStr(rw.Cells(1).Value, "PIPING WORKS COST SUMMARY PER ISOMETRIC DRAWINGS") = 1
Case InStr(rw.Cells(1).Value, "ITEM No.") = 1
Case InStr(rw.Cells(1).Value, "DRAWING NO") = 1
DrawingNo = Application.WorksheetFunction.Trim(Replace(Replace(Mid(rw.Cells(1).Value, 11), ".", "", 1, 1), ":", "", 1, 1))
NewSheet.Cells(DestRow, "M") = DrawingNo & " " & Application.Trim(Join(Application.Index(rw.Cells(2).Resize(, lastcolumn - 1).Value, 0))) ' & ", " & sht.Name
Case Else
CopyTheRow rw, NewSheet, DestRow
End Select
End If
Next rw
End If
End If
Next sht
NewSheet.Activate
Application.ScreenUpdating = True
End Sub
Sub CopyTheRow(rw, NewSheet, DestRow)
NewSheet.Cells(DestRow, 1).Resize(rw.Rows.Count, rw.Columns.Count) = rw.Value
If Left(rw.Cells(2), 5) = "GRAND" Then
NewSheet.Cells(DestRow, 1).Resize(, rw.Columns.Count + 1).Borders(xlEdgeBottom).Weight = xlThick
End If
DestRow = DestRow + rw.Rows.Count
End Sub

[p45cal]

Mmmm. I wonder if this was any good.

[misterewan]

Thanks p45cal..i have manage to add the columns and the datas needed to that report..please rely on this codings Sub DoTheSummary()

Dim NewSheet
Dim DestRow As Integer
Dim HeadersCopied As Boolean
Dim sht As Worksheet
Dim lastcolumn
Dim firstrow
Dim lastrow
Dim xxx As Range
Dim rangetoprocess
Dim rw
Dim cspipingvalue
Dim cwpno
Dim wrk As Workbook


Set wrk = ActiveWorkbook

Set NewSheet = wrk.Sheets.Add(After:=Worksheets(Worksheets.Count))
NewSheet.Name = "MySummary " & Format(Now(), "hh_mm_ss")
DestRow = 1
HeadersCopied = False
For Each sht In wrk.Sheets
lastcolumn = sht.UsedRange.Columns.Count
If Left(sht.Name, 9) <> "MySummary" Then
firstrow = Empty: lastrow = Empty
Set xxx = sht.Columns(1).Find(What:="Project ", LookIn:=xlFormulas, lookat:=xlPart, searchdirection:=xlNext)
If Not xxx Is Nothing Then firstrow = xxx.Row
Set xxx = sht.Columns(2).Find("GRAND TOTAL ", LookIn:=xlFormulas, After:=sht.Columns(2).Cells(sht.Rows.Count), lookat:=xlPart, searchdirection:=xlPrevious)
If Not xxx Is Nothing Then lastrow = xxx.Row
If Not HeadersCopied Then
Set xxx = sht.Columns(1).Find(What:="ITEM No.", LookIn:=xlFormulas, lookat:=xlWhole, searchdirection:=xlNext)
If Not xxx Is Nothing Then
CopyTheRow xxx.Resize(, lastcolumn), NewSheet, DestRow
NewSheet.Cells(DestRow - 1, "M") = "Drawing No."
NewSheet.Cells(DestRow - 1, "N") = "Drawing Rev No."
NewSheet.Cells(DestRow - 1, "o") = "CSS Line No."
NewSheet.Cells(DestRow - 1, "p") = "CSS Rev No."
HeadersCopied = True
End If
End If
If Not (lastrow = Empty Or firstrow = Empty) Then
Set rangetoprocess = Range(sht.Cells(firstrow, 1), sht.Cells(lastrow, lastcolumn))
For Each rw In rangetoprocess.Rows
If Not (rw.Cells(1) = Empty And rw.Cells(2) = Empty) Then
Select Case True
Case Left(rw.Cells(2).Value, 9) = "CS PIPING"
If cspipingvalue <> rw.Cells(2).Value Then
cspipingvalue = rw.Cells(2).Value
CopyTheRow rw, NewSheet, DestRow
End If
Case Left(rw.Cells(1).Value, 3) = "CWP"
If cwpno <> rw.Cells(1).Value Then
cwpno = rw.Cells(1).Value
CopyTheRow rw, NewSheet, DestRow
End If
Case Left(rw.Cells(2).Value, 8) = "Line No."
CopyTheRow rw, NewSheet, DestRow
CSS = Application.WorksheetFunction.Trim(Replace(Replace(Mid(rw.Cells(2).Value, 11), ".", "", 1, 1), ":", "", 1, 1))
Case InStr(rw.Cells(1).Value, "Project ") = 1
Case InStr(rw.Cells(1).Value, "Location ") = 1
Case InStr(rw.Cells(1).Value, "Owner ") = 1
Case InStr(rw.Cells(1).Value, "PIPING WORKS COST SUMMARY PER ISOMETRIC DRAWINGS") = 1
Case InStr(rw.Cells(1).Value, "ITEM No.") = 1
Case InStr(rw.Cells(1).Value, "DRAWING NO") = 1
DrawingNo = Application.WorksheetFunction.Trim(Replace(Replace(Mid(rw.Cells(1).Value, 11), ".", "", 1, 1), ":", "", 1, 1))
DRev = rw.Cells(4).Value
CSSRev = rw.Cells(12).Value
Case Else
CopyTheRow rw, NewSheet, DestRow
End Select
End If
Next rw
End If
End If
Next sht
NewSheet.Activate
End Sub

Sub CopyTheRow(rw, NewSheet, DestRow)
Dim lala
lala = rw.Columns.Count
NewSheet.Cells(DestRow, 1).Resize(, rw.Columns.Count) = rw.Value
NewSheet.Cells(DestRow, "M") = DrawingNo
NewSheet.Cells(DestRow, "N") = DRev
NewSheet.Cells(DestRow, "O") = CSS
NewSheet.Cells(DestRow, "P") = CSSRev
If Left(rw.Cells(2), 5) = "GRAND" Then
NewSheet.Cells(DestRow, 1).Resize(, rw.Columns.Count + 2).Borders(xlEdgeBottom).Weight = xlThick
End If
DestRow = DestRow + 1
End Sub
Thanks you very mush! I hope to be your friend here in this forum..I'll let you know if there are projects (I mean Jobs Projects) here so you could apply..