Copy many sheets into one twist

[Andy]

So I have to copy 173 sheets into one list. I found the code at:

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

to be very helpful. I'm using the copydatawithoutheaders macro

But I need to grab information from cell B5 of each sheet and add it to the
end of the list for each item. That is if it copies 4 rows and 5 columns, I
want each row to have a 6th column with the value in cell B5 of that sheet.

The AppendDataAfterLastColumn macro doesn't do what I want, it adds the
information into a new column (or maybe I'm modifying it incorrectly).

Any help would be greatly appreciated! Thanks in advance.

 

[eric]

please paste this code to visual basic edit

Const END_COLUMN = 6
Const START_ROW = 8


Private Sub GetProductOrder(sht As Excel.Worksheet, rng As Excel.Range)
Dim intI As Long
Dim intJ As Long
For intI = START_ROW To sht.UsedRange.Rows.Count
If sht.UsedRange.Cells(intI, 1) <> "" And sht.UsedRange.Cells(intI,
2) <> "" Then
For intJ = 1 To END_COLUMN
rng(1, intJ).Value = sht.UsedRange.Cells(intI, intJ).Value
Next
Set rng = rng.Offset(1, 0)
End If

Next
End Sub

Public Sub MergeData()
ClearData
Dim intI As Integer
Dim rng As Excel.Range
Set rng = Worksheets("MergeSheet").Range("A2:F2")

For intI = 1 To Worksheets.Count
If LCase(Worksheets(intI).Name) <> "MergeSheet" Then
Call GetProductOrder(Worksheets(intI), rng)
End If
Next
MsgBox "Merge data complete!"
End Sub

Private Sub ClearData()
Dim sht As Worksheet
Set sht = Worksheets("MergeSheet")
Dim rng As Excel.Range
Set rng = sht.UsedRange
Set rng = rng.Offset(1, 0)
rng.EntireRow.Clear
End Sub