VBA to merge multiple workbooks with demarcation

[akin]

Pls, I need help on how to merge multiple excel workbooks into single worksheet but with demarcation. I mean I want to know where one workbook data starts and ends, preferably filling the entire first column with workbook name.
What this mean is that as each workbook is copying to the new worksheet, it will pick its workbook name and use it to fill entire first column in the new worksheet and do that to all workbooks.
I had tried the code below before but I was not able to know where one workbook data starts and ends. And I need that knowledge to be able to proceed with further analysis.


Sub Button2_Click()

Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer

RowofCopySheet = 2 ' Row to start on in the sheets you are copying from

ThisWB = ActiveWorkbook.Name

path = GetDirectory("Select a folder containing Excel files you want to merge")

Application.EnableEvents = False
Application.ScreenUpdating = False

Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If

Filename = Dir()
Loop

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub

Thanks alot

[mana]

With Wkb.Sheets(1).UsedRange
Set CopyRng = Intersect(.Cells, .Offset(RowofCopySheet - 1))
End With
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Dest.Resize(CopyRng .Rows.Count).Value = Filename
CopyRng.Copy Dest.Offset(, 1)

[akin]

Thanks alot. I will try it and get back.

[akin]

Pls the expert, I am to use this script together with my own. I mean the one that merge multiple workbooks into single one. Or it use it alone.
It is as if I am not getting it. Thanks

[Bob Phillips]

Sub Button2_Click()
Dim Wkb As Workbook
Dim wbDest As Workbook, shtDest As Worksheet, source As Worksheet
Dim path As String, ThisWB As String, Filename As String
Dim CopyRng As Range, Dest As Range
Dim currLastrow As Long, prevlastrow As Long

On Error GoTo err_exit
Application.EnableEvents = False
Application.ScreenUpdating = False

currLastrow = 2 ' Row to start on in the sheets you are copying from

ThisWB = ActiveWorkbook.Name
Set shtDest = ActiveWorkbook.Sheets(1)

path = GetDirectory("Select a folder containing Excel files you want to merge")

Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub

Do Until Filename = vbNullString

If Not Filename = ThisWB Then

Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
Set source = Wkb.Sheets(1)
Set CopyRng = source.Range(source.Cells(currLastrow, 1), source.Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))

Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest

Wkb.Close False

prevlastrow = currLastrow
currLastrow = shtDest.Cells(shdest.Rows.Count, "B").End(xlUp).Row
shdest.Cells(prevlastrow, "A").Resize(currLastrow - prevlastrow + 1).Value = Filename
End If

Filename = Dir()
Loop

shdest.Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"

Exit Sub

GoTo err_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[akin]

[QUOTE=Bob Phillips;409868][CODE]Sub Button2_Click()
Dim Wkb As Workbook
Dim wbDest As Workbook, shtDest As Worksheet, source As Worksheet
Dim path As String, ThisWB As String, Filename As String
Dim CopyRng As Range, Dest As Range
Dim currLastrow As Long, prevlastrow As Long

On Error GoTo err_exit
Application.EnableEvents = False
Application.ScreenUpdating = False

currLastrow = 2 ' Row to start on in the sheets you are copying from

ThisWB = ActiveWorkbook.Name
Set shtDest = ActiveWorkbook.Sheets(1)

path = GetDirectory("Select a folder containing Excel files you want to merge")

Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub

Do Until Filename = vbNullString

If Not Filename = ThisWB Then

Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
Set source = Wkb.Sheets(1)
Set CopyRng = source.Range(source.Cells(currLastrow, 1), source.Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))

Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest

Wkb.Close False

prevlastrow = currLastrow
currLastrow = shtDest.Cells(shdest.Rows.Count, "B").End(xlUp).Row
shdest.Cells(prevlastrow, "A").Resize(currLastrow - prevlastrow + 1).Value = Filename
End If

Filename = Dir()
Loop

shdest.Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"

Exit Sub

GoTo err_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Pls expert, can you help me check this code again. It is not running at all. I will click run, it will just fail to run and not doing anything. You yourself can try it. Thanks

[akin]

Pls expert, can you help me check this code again. It is not running at all. I will click run, it will just fail to run and not doing anything. You yourself can try it. Thanks

[akin]

Pls, there is compile error: Label not defined
Thanks

[Bob Phillips]

Sorry, my error


Sub Button2_Click()
Dim Wkb As Workbook
Dim wbDest As Workbook, shtDest As Worksheet, source As Worksheet
Dim path As String, ThisWB As String, Filename As String
Dim CopyRng As Range, Dest As Range
Dim currLastrow As Long, prevlastrow As Long

On Error GoTo err_exit
Application.EnableEvents = False
Application.ScreenUpdating = False

currLastrow = 2 ' Row to start on in the sheets you are copying from

ThisWB = ActiveWorkbook.Name
Set shtDest = ActiveWorkbook.Sheets(1)

path = GetDirectory("Select a folder containing Excel files you want to merge")

Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub

Do Until Filename = vbNullString

If Not Filename = ThisWB Then

Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
Set source = Wkb.Sheets(1)
Set CopyRng = source.Range(source.Cells(currLastrow, 1), source.Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))

Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest

Wkb.Close False

prevlastrow = currLastrow
currLastrow = shtDest.Cells(shdest.Rows.Count, "B").End(xlUp).Row
shdest.Cells(prevlastrow, "A").Resize(currLastrow - prevlastrow + 1).Value = Filename
End If

Filename = Dir()
Loop

shdest.Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"

Exit Sub

err_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[snb]

@akin

Have you got any VBA knowledge ?