Merge Workbook in VBA

[VBAnewbie234]

I am attempting to merge multiple files from a folder into one workbook. So far I have been able to merge the data, but when I attempt to add the file name in last column of the the results I am getting an error message. I am really new to VBA and any help is greatly appreciated.

The error message reads: Compile erro: For without Next


My code:

Private Declare Function SetCurrentDirectoryA Lib _
"MergeSpecificWorkbooks" (ByVal lpPathName As String) As LongSub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub

Sub MergeSpecificWorkbooks()
Dim MyPath As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant


' Set application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
' Change this to the path\folder location of the files.
ChDirNet "DATA SOURCE"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

' Loop through all files in the myFiles array.
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A6:j250")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If the source range uses 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 "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column H.
With sourceRange
BaseWks.Cells(rnum, "H"). _
Resize(.Rows.Count).Value = FName(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
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


'Delete Blank rows in range
Set ws = ActiveSheet
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
With ws.Range("A2:A" & LastRow)
If WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With

ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub

 

[mikerickson]

I suspect that there is an unclosed If .. End If or With ... End With

 

[VBAnewbie234]

That was my first thought, but I'm not seeing one I didn't stray much from my source.

I found my code from : Merging Data from Multiple Workbooks into a Summary Workbook in Excel

 

[VBAnewbie234]

Partially fixed. There is no compile error and my data feeds into the master workbook with the file name in column A. However, the file name show the entire file path. I am really just looking for the actual excel file name. Which is Accountant.DateRequested. Is there another way I can feed this information into the results? They are on the form in B1 and F1.

I guess my question is, is there a way the Accoutants name and date requested can be pulled in with the merge to be places in column A before the results from that form?


Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub

Sub MergeSpecificWorkbooks()
Dim MyPath As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant

' Set application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
' Change this to the path\folder location of the files.
ChDirNet "DATA SOURCE"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

' Loop through all files in the myFiles array.
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A6:j43")
End With


If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If the source range uses 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 "There are not enough rows in the target worksheet."
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 = FName(FNum)
End With

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


' Copy the values from the source range
' to the destination range.
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 FNum
BaseWks.Columns.AutoFit
End If

'Delete Blank rows in range
Set ws = ActiveSheet
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
With ws.Range("B2:F250" & LastRow)
If WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub