Dear all,
I am new to <acronym title="visual basic for applications">VBA</acronym> and this forum. I have been struggling with this new piece of code that i have managed to write. I find this works fine for some files , but some files it does not copy the data.
This macro , opens a directory , and from all the excel workbooks in that directory , it opens the second worksheet and copies the data from column A to column U , into the workbook on which the macro is kept ,into worksheet 4
I tried to put error handling and i observe it gives error code 6 :Overflow error.
Another observation was , i was trying to find out the difference between the file from which it was able to copy and the file which it is not copying. I could not make out much. I tried copying the format of the file which was working and used the same format (using format painter) in the other files which did not work , and surprisingly after i did that, it works fine.
I am unable to figure out what the formatting related thing has got to do with this code.
I am not sure how to handle this. Any help would be of great assistance to me
CODE
Sub MergeAllWorkbooks()
On Error GoTo finish
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim DestLastRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim filecount As Integer
' Set the sheet where data has to be copied
Set SummarySheet = ThisWorkbook.Worksheets(4)
'Get the folder where the files are present
FolderPath = GetFolder("D:\") + "\"
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Clear the existing data in the utility test results sheet
Dim mbResult As Long
mbResult = MsgBox("Do you want to clear the data in the Test Results worksheet of the IPR utility?", vbYesNo)
' SourceLastRow keeps track of where to insert new rows in the destination workbook.
DestLastRow = SummarySheet.Columns(36).Find(What:="*", _
After:=SummarySheet.Cells.Range("AJ1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
If mbResult = vbYes And DestLastRow > 1 Then
End If
' Loop until Dir returns an empty string.
filecount = 0
Application.ShowWindowsInTaskbar = False
Application.ScreenUpdating = False
Do While FileName <> ""
filecount = filecount + 1
On Error Resume Next
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
Application.StatusBar = "Fetching Data from File : " & FileName
' to turn off filters in the source files
If WorkBk.Worksheets(2).AutoFilterMode Then
If WorkBk.Worksheets(2).FilterMode Then
WorkBk.Worksheets(2).ShowAllData
End If
ElseIf WorkBk.Worksheets(2).FilterMode Then
WorkBk.Worksheets(2).ShowAllData
End If
' Set the source range
' It can span multiple rows.
Dim LastRow As Long
LastRow = WorkBk.Worksheets(2).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(2).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Set SourceRange = WorkBk.Worksheets(2).Range("A2:U" & LastRow)
' Set the destination range to start at column A and be the same size as the source range.
Set DestRange = SummarySheet.Range("A" & DestLastRow + 1)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
SummarySheet.Range("AJ" & DestLastRow + 1 & ":AJ" & LastRow + DestLastRow).Value = FileName
' Increase DestLastRow so that we know where to copy data next.
DestLastRow = DestLastRow + DestRange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
Application.StatusBar = "Data Fetched Successfully"
Application.ShowWindowsInTaskbar = True
Application.ScreenUpdating = True
' Call AutoFit on the destination sheet so that all data is readable.
MsgBox ("The data has been successfully copied from " & filecount & " files")
SummarySheet.Columns.AutoFit
SummarySheet.Columns("V").Hidden = True
SummarySheet.Columns("W").Hidden = True
SummarySheet.Columns("X").Hidden = True
SummarySheet.Columns("Y").Hidden = True
SummarySheet.Columns("Z").Hidden = True
SummarySheet.Columns("AF").Hidden = True
SummarySheet.Columns("AG").Hidden = True
SummarySheet.Columns("AH").Hidden = True
Exit Sub
finish:
Application.ShowWindowsInTaskbar = True
Application.ScreenUpdating = True
Application.StatusBar = ""
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Resume Next
'MsgBox ("Some error occurred while fetching data from selected files " & vbNewLine & "Copied data from " & filecount & " files")
SummarySheet.Columns.AutoFit
SummarySheet.Columns("V").Hidden = True
SummarySheet.Columns("W").Hidden = True
SummarySheet.Columns("X").Hidden = True
SummarySheet.Columns("Y").Hidden = True
SummarySheet.Columns("Z").Hidden = True
SummarySheet.Columns("AF").Hidden = True
SummarySheet.Columns("AG").Hidden = True
SummarySheet.Columns("AH").Hidden = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where the files are present"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
ChDir "C:\"
End Function
CODE
I am new to <acronym title="visual basic for applications">VBA</acronym> and this forum. I have been struggling with this new piece of code that i have managed to write. I find this works fine for some files , but some files it does not copy the data.
This macro , opens a directory , and from all the excel workbooks in that directory , it opens the second worksheet and copies the data from column A to column U , into the workbook on which the macro is kept ,into worksheet 4
I tried to put error handling and i observe it gives error code 6 :Overflow error.
Another observation was , i was trying to find out the difference between the file from which it was able to copy and the file which it is not copying. I could not make out much. I tried copying the format of the file which was working and used the same format (using format painter) in the other files which did not work , and surprisingly after i did that, it works fine.
I am unable to figure out what the formatting related thing has got to do with this code.
I am not sure how to handle this. Any help would be of great assistance to me
CODE
Sub MergeAllWorkbooks()
On Error GoTo finish
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim DestLastRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim filecount As Integer
' Set the sheet where data has to be copied
Set SummarySheet = ThisWorkbook.Worksheets(4)
'Get the folder where the files are present
FolderPath = GetFolder("D:\") + "\"
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Clear the existing data in the utility test results sheet
Dim mbResult As Long
mbResult = MsgBox("Do you want to clear the data in the Test Results worksheet of the IPR utility?", vbYesNo)
' SourceLastRow keeps track of where to insert new rows in the destination workbook.
DestLastRow = SummarySheet.Columns(36).Find(What:="*", _
After:=SummarySheet.Cells.Range("AJ1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
If mbResult = vbYes And DestLastRow > 1 Then
SummarySheet.Range("A2" & ":U" & DestLastRow).Clear
SummarySheet.Range("AJ2:AJ" & DestLastRow).Clear
DestLastRow = 1
SummarySheet.Range("AJ2:AJ" & DestLastRow).Clear
DestLastRow = 1
End If
' Loop until Dir returns an empty string.
filecount = 0
Application.ShowWindowsInTaskbar = False
Application.ScreenUpdating = False
Do While FileName <> ""
filecount = filecount + 1
On Error Resume Next
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
Application.StatusBar = "Fetching Data from File : " & FileName
' to turn off filters in the source files
If WorkBk.Worksheets(2).AutoFilterMode Then
If WorkBk.Worksheets(2).FilterMode Then
WorkBk.Worksheets(2).ShowAllData
End If
ElseIf WorkBk.Worksheets(2).FilterMode Then
WorkBk.Worksheets(2).ShowAllData
End If
' Set the source range
' It can span multiple rows.
Dim LastRow As Long
LastRow = WorkBk.Worksheets(2).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(2).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Set SourceRange = WorkBk.Worksheets(2).Range("A2:U" & LastRow)
' Set the destination range to start at column A and be the same size as the source range.
Set DestRange = SummarySheet.Range("A" & DestLastRow + 1)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
SummarySheet.Range("AJ" & DestLastRow + 1 & ":AJ" & LastRow + DestLastRow).Value = FileName
' Increase DestLastRow so that we know where to copy data next.
DestLastRow = DestLastRow + DestRange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
Application.StatusBar = "Data Fetched Successfully"
Application.ShowWindowsInTaskbar = True
Application.ScreenUpdating = True
' Call AutoFit on the destination sheet so that all data is readable.
MsgBox ("The data has been successfully copied from " & filecount & " files")
SummarySheet.Columns.AutoFit
SummarySheet.Columns("V").Hidden = True
SummarySheet.Columns("W").Hidden = True
SummarySheet.Columns("X").Hidden = True
SummarySheet.Columns("Y").Hidden = True
SummarySheet.Columns("Z").Hidden = True
SummarySheet.Columns("AF").Hidden = True
SummarySheet.Columns("AG").Hidden = True
SummarySheet.Columns("AH").Hidden = True
Exit Sub
finish:
Application.ShowWindowsInTaskbar = True
Application.ScreenUpdating = True
Application.StatusBar = ""
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Resume Next
'MsgBox ("Some error occurred while fetching data from selected files " & vbNewLine & "Copied data from " & filecount & " files")
SummarySheet.Columns.AutoFit
SummarySheet.Columns("V").Hidden = True
SummarySheet.Columns("W").Hidden = True
SummarySheet.Columns("X").Hidden = True
SummarySheet.Columns("Y").Hidden = True
SummarySheet.Columns("Z").Hidden = True
SummarySheet.Columns("AF").Hidden = True
SummarySheet.Columns("AG").Hidden = True
SummarySheet.Columns("AH").Hidden = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Folder where the files are present"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
ChDir "C:\"
End Function
CODE