Merge Multiple Workbooks

[Guest]

Hi,

Wonder if someone acn help me please.

I am using, and have been for sometime some great coding below, (admitedly
not mine, a great programmer called Ken Wright) to copy rows of data from
multiple workbooks and pasting them into one master sheet. The macro also
copies the header of the first workbook it extracts the data from and ignores
the headers in the rest.

Sub CopyFromMultipleFiles()

Dim lrow As Long
Dim Hdrs As Long
Dim NumCols As Long
Dim ffc As Long
Dim i As Long
Dim R As Integer
Dim WBn As String
Dim rng As Range
Dim WB As Workbook
Dim WBr As Range
Dim WBlstrw As Long
Dim CurWkb As Workbook
Dim CurWks As Worksheet
Dim CurWksLrow As Long
Dim strStartDir As String
Dim UserFile As String
Dim Sht As Worksheet

On Error Resume Next

UserFile = PickFolder(strStartDir)
If UserFile = "" Then
MsgBox "Canceled"
Exit Sub
End If

Set CurWkb = Workbooks.Add

'CurWks will always refer to the Summary worksheet you are creating
Set CurWks = CurWkb.Worksheets(1)

Application.ScreenUpdating = False

'Clear out the Summary worksheet
With CurWks
.Activate
.UsedRange.Delete
End With

lrow = 1
Hdrs = 1
With Application.FileSearch
.SearchSubFolders = True
.NewSearch
.Filename = ".xls"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks
.Execute

ffc = .FoundFiles.Count

For i = 1 To ffc

'WB will always refer to the source Workbook that
'you are interrogating at the time
Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i))

If i = 1 Then

NumCols = WB.Sheets(1).UsedRange.Column - 1 + _
WB.Sheets(1).UsedRange.Columns.Count
CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _
WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value

End If

Application.StatusBar = "Currently Processing file " & i & " of
" & ffc

WBn = WB.Name
WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

'Copy the data across
CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs,
NumCols).Value = _
WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs,
NumCols).Value

' 'Put the filename in the first Col as an index value
' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value =
WBn
lrow = lrow + (WBlstrw - Hdrs)

WB.Close savechanges:=False
Next
End With

Set WB = Nothing
Set CurWks = Nothing
Set CurWkb = Nothing

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub


The problem I have is that the files I get containing the data I extract
have changed. The above macro assumes that there is always data in the A
column and uses this as a guide to copy the data within the whole row. This
is now not always the case.

With my very limited VB knowledge, by changing things around, adding and
removing the code I think I've located the line that needs to change as this:
'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row'

I am fairly new to VB and not that confident and I've tried to change the
Cells(Row to Range, but this doesn't work.

Could somebody tell me please how I could change the code so it looks at a
range rather than column A.

Many thanks and regards

Chris

 

[Ron de Bruin]

You can find a example here that use a function to find the last row
http://www.rondebruin.nl/copy3.htm

 

[Guest]

Ron,

Thanks for getting back to me.

Like I said I am very new to VB and I do struggle to understand some of code.

I looked at the example of codes that you gave me the link to and what I've
tried to do is take the line that copies the rows of data and import into the
macro that I was using because I really needed the code to look for specific
file names and also to copy the header from the first file it extracts and
ignore the rest. The problem I have is that it only copies the header and not
the data.

From the code below could you perhaps give me a little guidance as to where
I am going wrong.

Sub Copy_From_Multiple_P14_Files()

Dim Lrow As Long
Dim Hdrs As Long
Dim NumCols As Long
Dim ffc As Long
Dim i As Long
Dim R As Integer
Dim WBn As String
Dim rng As Range
Dim WB As Workbook
Dim WBr As Range
Dim WBlstrw As Long
Dim CurWkb As Workbook
Dim CurWks As Worksheet
Dim CurWksLrow As Long
Dim strStartDir As String
Dim UserFile As String
Dim Sht As Worksheet
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim shLast As Long
Dim Last As Long

On Error Resume Next

Set CurWkb = Workbooks.Add

Set CurWks = CurWkb.Worksheets(1)

Application.ScreenUpdating = False

With CurWks
.Activate
.UsedRange.Delete
End With

Lrow = 1
Hdrs = 1
With Application.FileSearch
.SearchSubFolders = True
.NewSearch
.Filename = "PAck*.csv"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks
.Execute

ffc = .FoundFiles.Count

For i = 1 To ffc

Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i))

If i = 1 Then

NumCols = WB.Sheets(1).UsedRange.Column - 1 + _
WB.Sheets(1).UsedRange.Columns.Count
CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _
WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value

End If

Application.StatusBar = "Currently Processing file " & i & " of
" & ffc

sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last +
1, "A")

CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs,
NumCols).Value = _
WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value

Lrow = Lrow + (WBlstrw - Hdrs)

WB.Close savechanges:=False
Next
End With

Set WB = Nothing
Set CurWks = Nothing
Set CurWkb = Nothing

Application.ScreenUpdating = True
Application.StatusBar = False


End Sub

Any help would be gratefully appreciated.

many thanks and kind regards

Chris

 

[Ron de Bruin]

Hi

Try to forget FileSearch.
In Office 2007 it is not available anymore and it is not always working correct

You can use the code from my site and look in this example
http://www.rondebruin.nl/copy3.htm#range2
Where I test the file name with
If LCase(Left(FNames, 4)) = "week" Then

You can build that test in this macro
http://www.rondebruin.nl/copy3.htm#header

 

[Guest]

Ron,

Thanks very much for replying.

I see what you mean, I'll give it a go and let you know how I get on.

Regards and many thanks

Chris

 

[Guest]

Hi Ron,

I must be missing somehting obvious here!

I've taken the coding that you suggested and changed the file path, the
range that I want the code to look at and the file extension.

The macro runs but it doesn't extract the data.

Any ideas please?

Kind regards

Chris

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


Sub Example7()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim lrow As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "D:\My Documents"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.csv")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
rnum = 1
Do While FNames <> ""
If LCase(Left(FNames, 4)) = "weeks" Then
Set mybook = Workbooks.Open(FNames)
lrow = LastRow(mybook.Sheets(1))
Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow)
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")
sourceRange.Copy destrange
mybook.Close False
rnum = rnum + SourceRcount
End If
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True

End Sub

 

[Ron de Bruin]

Hi Chris

If LCase(Left(FNames, 4)) = "weeks" Then

weeks are 5 characters not 4

 

[Guest]

Hi Ron,

I've made the change, unfortunately as before it seems to run, but nothing
happens!

I was thinking about a couple of things where the problem may be. Wherabouts
should this be:

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

At the moment it's at the very beginning of my coding, and it's split with
the line across the page almost as if it's two separate bits of coding. I did
try and add it in the middle of the rest of coding, but it didn't even run.

The second thing is. Does 'weeks' relate to a file that it is looking for
or, is it creating a file called 'weeks'?

Thanks Ron for bearing with me and for your help

Regards

Chris

 

[Ron de Bruin]

There are a few problems in your code
I post a example within a hour

 

[Ron de Bruin]

Ok

Copy both the function in a normal module
This is my tester so change the path to yours.

And also this line
If LCase(Left(FNames, 4)) = "book" Then
Now it only run for csv file names that start with book


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


Sub Example7()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim lrow As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Users\Ron\test"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.csv")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
'clear all cells on the first sheet
rnum = 1

Do While FNames <> ""
If LCase(Left(FNames, 4)) = "book" Then
Set mybook = Workbooks.Open(FNames)
lrow = LastRow(mybook.Sheets(1))
Set sourceRange = mybook.Worksheets(1).Range("A2:IV" & lrow)
'Copy from A2:IV? (till the last row with data on your sheet)
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only the values

' With sourceRange
' Set destrange = basebook.Worksheets(1).Cells(rnum, "A"). _
' Resize(.Rows.Count, .Columns.Count)
' End With
' destrange.Value = sourceRange.Value

mybook.Close False
rnum = rnum + SourceRcount
End If
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Guest]

Ron,

Thanks so very much for the continued help, it really is appreciated.

I've been working on this for the last few hours and I've got the coding to
work, but I've also found out where the problem is.

The macro doesn't work if I save this within the default 'PERSONAL.xls'
macro folder, any ideas?

Many thanks once again and kind regards

 

[Ron de Bruin]

The macro doesn't work if I save this within the default 'PERSONAL.xls'

macro folder, any ideas?

Set basebook = ThisWorkbook

Change to ActiveWorkbook

 

[Guest]

Ron,

Thanks, it works a treat.

Well, that's it, it all works great.

Thanks you so very much for your continued help and patience. It has really
helped me out.

Many thanks and kind regards

Chris

 

[Ron de Bruin]

You are welcome

Thanks for the feedback