help merge documents into a master file

  • Thread starter Thread starter RompStar
  • Start date Start date
R

RompStar

Ok, on my local network \\

I have 5 different Excel.xls documents,

doc1.xls
doc2.xls
doc3.xls
doc4.xls
doc5.xls

in each document there is a single sheet, each one names differently
and of course I know their names...

EAch doc is exactly the same in desigh, has 4 columns, A, B, C, D

A: has Department Name
B: has Date
C: has Employee Name
D: Daily Status

A1:D1 has headers and everything below that starting at

A2:D2 is data...

So, there are 5 different documents, I simply want to merge them all
into a single sheet, keep the headers and paste the data... only select
data filled, ignore blank rows below last used...

I need to do this everyday.... so manual cut and paste takes a good 10
minutes and I don't want to waste my time, as I have so many things to
do...

So I guess I need a VBA script that will go and grab these files from
the network and paste them into a Master Append document that holds
them all...

Maybe have an update button, so the next day it looks into these files
and grabs only new dates that don't match in the master document...

Any ideas ? maybe script that have been wrote already...
 
Ok, I am trying to get the files into my current open workbook, (merge)
that are on the network \\ instead of c:\

and also I want to merge any files that start with: appendfile-*.xls

Currently I am getting an error:

Run-time error '5': Invalid procedue call or argument. Is that error
because I am trying to import over the network and your code wasn't
ment to
work over the network ? can you help me out with that ? I would be
greatfull.

I use Excel 2003, SP1

Option Explicit

Sub MergeFiles()
Dim basebook As Workbook ' The current open book that files will be
merged into
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 = "\\Cpitgcfs15\wm&ds\ROSTER\2005\SORT-REC-TERESA"
ChDrive MyPath
ChDir MyPath
FNames = Dir("appendfile-*.xls")
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 <> ""
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
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


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
 
I tried running this code, I press play, it does it's thing, and
nothing really is imported, the sheet I run this from is empty.. did I
do something wrong ?

Option Explicit

Function Split97(sStr As Variant, sdelim As String) As Variant
' Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") &
"""}")
End Function

Sub TestFile4()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim i As Long
Dim a As Long
Dim vArr As Variant
Dim sFname As String
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "\\Cpitgcfs15\wm&ds\ROSTER\2005\SORT-REC-TERESA"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
rnum = 1
For i = 1 To .FoundFiles.Count
vArr = Split97(.FoundFiles(i), "\")
sFname = vArr(UBound(vArr))
If Left(sFname, 4) = "appendfile-" Then
Set mybook = Workbooks.Open(.FoundFiles(i))
Set sourceRange =
mybook.Worksheets(1).Range("a1:d25")
a = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum,
1)
sourceRange.Copy destrange
mybook.Close
rnum = rnum + a
End If
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
 
this code works, but it imports all the files into seperate sheets, how
hard is it to import them into a single running sheet ?

Option Explicit

Sub TestFile3()
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "\\Cpitgcfs15\wm&ds\ROSTER\2005\SORT-REC-TERESA"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
mybook.Worksheets(1).Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
ActiveSheet.Name = mybook.Name
mybook.Close
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
 
the Sub TestFile3() code works... not exactly how I want it, but
beggers can't be choosers I guess..

so, since this code works, let's expand on it..

How to make it so that. it looks in more then one PATH ?

I mean is this legal ?

.LookIn = "\\localnetwork\Dir1"
.LookIn = "\\localnetwork\Dir2"

How can I put in different paths ? more then one ?


-----------------

Option Explicit

Sub TestFile3()
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "\\localnetwork\Dir1"
.LookIn = "\\localnetwork\Dir2"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
mybook.Worksheets(1).Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
ActiveSheet.Name = mybook.Name
mybook.Close
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
 
Use the range Example on that page and use this to copy the usedrange

Set sourceRange = mybook.Worksheets(1).UsedRange

Or currentregion

Set sourceRange = mybook.Worksheets(1).Range("A1").CurrentRegion
 
I like this code the most, beccause it looks for last row used and I
get reference what files names to look for... that they begin with, I
tried to apply the With Application.FileSearch from the other script
that works for me, can you help to make it fit ?

I am going to try on my own, but my skills are not evolved enough, I
only been reading books for about 3-4 weeks..
 
Option Explicit

Sub MergeFiles()
Dim basebook As Workbook ' The current open book that files will be
merged into
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


With Application.FileSearch
.NewSearch
.LookIn = "\\localnetwork"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks

' ChDrive MyPath
' ChDir MyPath

FNames = Dir("appendfile-*.xls")
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 <> ""
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
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
End With
Application.ScreenUpdating = True
End Sub


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
 
Hi RompStar

I promis I update my webpage this weekend
I will post here when it is ready
 
this code works, I had to look up the definitions for the fileSearch
Object:

Well, atleast it works and is saving me time, so thanks :- )

Now they are imported, but all on seperate sheets, so my next goal is
to be able to import them all, but into a single sheet, not spread out
like that on each new sheets and I really like that code... for looking
for the last row used.. To import them all into a single sheet and
stack them under each other, since the data format is exactly the same.

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

--------------------------------------------------------

Option Explicit

Sub TestFile3()
Dim basebook As Workbook
Dim mybook As Workbook
Dim i As Long
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.Filename = "appendfile-*.xls"
.LookIn = "\\local\net\work"
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks

If .Execute() > 0 Then
Set basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
mybook.Worksheets(1).Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
ActiveSheet.Name = mybook.Name
mybook.Close
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
 
Ok, "promise" :- )

I really can't demands things from you since, you do this for free :- )

Whenever you get around to it, until then I'll poke around and try to
figure it out
by my own...

:- )
 
Back
Top