Merging data from several sheets

[claytorm]

Hello,

I am new to VB, and would appreciate some help with this. I have
script which pulls identically formatted data from several data sheet
into one master sheet. This works fine.

In cell A1 of all the data sheets is a three letter code. I want t
place this in Column A of the mastersheet in all the rows containin
data from the same data sheet.

I attach a sheet which shows the result I am aiming at.

Here is the code I am currently using:

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

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

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

sh.Range(sh.Rows(3), sh.Rows(shLast)).Cop
DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below t
copy only the values
'or use the PasteSpecial option to paste the forma
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
Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub


Thanks for any help,

Bertie

Attachment filename: collateeg.xls
Download attachment: http://www.excelforum.com/attachment.php?postid=65367

 

[Ron de Bruin]

Hi

I don't look at your workbook but copy the two lines of code below the existing
line this text.

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

 

[claytorm]

Thanks Ron!

This worked great.

Bertie