PDA

View Full Version : [SOLVED] Merge Excel Files in Folder into Bottom of Current Worksheet



sheexin
06-23-2015, 07:53 PM
Hi, I'm currently using Ron De Bruin's code to merge multiple excel files in a folder. I've managed to modify the code to paste the data into the current workbook, instead of a new one.

I want to paste the data at the first unfilled row of the current worksheet as the pasted data should add on to previous pasted data. The worksheet would be updated regularly with new combined files from new folders. I know that to find the first unfilled cell would be Range (“A1”).End(xlDown).Offset(1,0) but I only managed to edit the positions of Please Wait and Ready, but not the pasted data. If I'm not wrong, the pasted data would start from A3 onwards. Any suggestions?


Option Explicit


'Important: this Dim line must be at the top of your module
Public MyFiles As String


Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 3.0 : 1 May 2015
'Thanks to DJ Bazzie Wazzie(poster on MacScripter) for his great help.
Dim ScriptToRun As String
Dim folderPath As String
Dim FileNameFilter As String
Dim Extensions As String


On Error Resume Next
folderPath = MacScript("choose folder as string")
If folderPath = "" Then Exit Function
On Error GoTo 0


Select Case ExtChoice
Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)" 'xls, xlsx , xlsm, xlsb
Case 1: Extensions = "xls" 'Only xls
Case 2: Extensions = "xlsx" 'Only xlsx
Case 3: Extensions = "xlsm" 'Only xlsm
Case 4: Extensions = "xlsb" 'Only xlsb
Case 5: Extensions = "csv" 'Only csv
Case 6: Extensions = "txt" 'Only txt
Case 7: Extensions = ".*" 'All files with extension, use *.* for everything
Case 8: Extensions = "(xlsx|xlsm|xlsb)" 'xlsx, xlsm , xlsb
Case 9: Extensions = "(csv|txt)" 'csv and txt files
'You can add more filter options if you want,
End Select


Select Case FileFilterOption
Case 0: FileNameFilter = "'.*/[^~][^/]*\\." & Extensions & "$' " 'No Filter
Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\\." & Extensions & "$' " 'Begins with
Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\\." & Extensions & "$' " ' Ends With
Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\\." & Extensions & "$' " 'Contains
End Select


folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
Chr(34) & " to return quoted form of it's POSIX Path")
folderPath = Replace(folderPath, "'\''", "'\\''")


If Val(Application.Version) < 15 Then
ScriptToRun = ScriptToRun & "set OSAConverter to ""osascript -e 'on run argv" & Chr(13)
ScriptToRun = ScriptToRun & "return posix file (item 1 of argv) as string" & Chr(13)
ScriptToRun = ScriptToRun & "end run' {} \\;""" & Chr(13)
ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & " -maxdepth " & _
Level & " -exec "" & OSAConverter"
Else
ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """ "
End If
On Error Resume Next
MyFiles = MacScript(ScriptToRun)
On Error GoTo 0
End Function




Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
'Case 1 = last row
'Case 2 = last column
'Case 3 = last cell
Dim lrw As Long
Dim lcol As Integer


Select Case choice


Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0


Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0


Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0


On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0


On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function






Sub MergeCode2()
Dim BaseWks As Worksheet
Dim rnum As Long
Dim CalcMode As Long
Dim MySplit As Variant
Dim FileInMyFiles As Long
Dim Mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim SourceRcount As Long
Dim FirstCell As String


'Add a new workbook with one sheet
Set BaseWks = ThisWorkbook.Sheets("sheet1")
BaseWks.Range("A1").Font.Size = 36
BaseWks.Range("A1").Value = "Please Wait"
rnum = 3


'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With


'Clear MyFiles to be sure that it not return old info if no files are found
MyFiles = ""


'Get the files, set the level of folders and extension in the code line below
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
'Level : 1= Only the files in the folder you select, 2 to ? levels of subfolders
'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3


' Work with the files if MyFiles is not empty.
If MyFiles <> "" Then


MySplit = Split(MyFiles, Chr(13))
For FileInMyFiles = LBound(MySplit) To UBound(MySplit)


Set Mybook = Nothing
On Error Resume Next
Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
On Error GoTo 0


If Not Mybook Is Nothing Then


On Error Resume Next


With Mybook.Worksheets(1)
FirstCell = "A2"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
'Test if the row of the last cell is equal to or greater than the row of the first cell.
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
End With


If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0


If Not sourceRange Is Nothing Then


SourceRcount = sourceRange.Rows.Count


If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
Mybook.Close savechanges:=False
GoTo ExitTheSub
Else


'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MySplit(FileInMyFiles)
End With


'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)


'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value


rnum = rnum + SourceRcount
End If
End If
Mybook.Close savechanges:=False
End If


Next FileInMyFiles
BaseWks.Columns.AutoFit
End If


ExitTheSub:
BaseWks.Range("A1").Value = "Ready"
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub








Thanks!

snb
06-24-2015, 04:06 AM
I'd use


sub M_snb()
sn=filter(split(createobject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xls*"" /b/s"),vbcrlf),":")

for j=0 to ubound(sn()
with getobject(sn(j))
sp=.sheets(1).usedrange
.close 0
end with

thisworkbook.sheet1.cells(rows.count,1).end(xlup).offset(1).resize(ubound(s p),ubound(sp,2))=sp
next
End sub

sheexin
06-24-2015, 06:32 PM
Thanks for the reply. There were some errors so I've adjusted the code as such:




Sub M_snb()
sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xls*"" /b/s"), vbCrLf), ":")

For j = 0 To UBound(sn())
With GetObject(sn(j))
sp = .Sheets(1).UsedRange
.Close 0
End With

ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp), UBound(sp, 2)) = sp
Next
End Sub




However, when I run the sub, it says run time error 429, activex component can't create object. sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir ""G:\OF\*.xls*"" /b/s"), vbCrLf), ":") is highlighted.

Moreover, am I supposed to run this sub after running the mergecode2?

In case it matters, I'm using excel 2011 on mac. Thanks!

snb
06-24-2015, 10:55 PM
In case it matters, I'm using excel 2011 on mac.
It's essential.
My code assumes running in Windows (that's wscript.shell).

Tom Jones
06-25-2015, 01:50 AM
As SNB says the code is designed to run under Windows, but would have to change the path to the folder with the files - in code is G:\OF\ and I doubt that is the same way and where are your files.

sheexin
06-25-2015, 01:58 AM
Hi all, I have found a simpler roundabout solution. Basically, I created a second sheet where the database should be. Sheet 1 would be where Ron de Bruin's code is run, and then I would use VBA to copy and paste the relevant rows and columns into the next empty cell in Sheet 2. My code is as such:

Sub copy()



'copy
Worksheets("Sheet1").Activate
If IsEmpty(Range("A1").Value) = False Then
Range("B3").Select
Range(ActiveCell, ActiveCell.End(xlToRight).End(xlDown)).Select
Selection.copy

'paste
'empty
Worksheets("All").Activate
If IsEmpty(Range("A1").Value) = True Then
Range("A1").PasteSpecial
Range("A1").PasteSpecial xlPasteColumnWidths

End If
'not empty
If IsEmpty(Range("A1").Value) = False Then
Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteColumnWidths
Range("A1").End(xlDown).Offset(1, 0).PasteSpecial



End If


Worksheets("Sheet1").Cells.Clear

End If

If IsEmpty(Range("A1").Value) = True Then
MsgBox ("No Data")
End If


End Sub


Thanks all for your kind help!