BenChod
06-04-2017, 08:12 AM
Hello All -
I am using the following code using ADO connection to extract data from multiple workbooks without them being opened to speed up the process. I made minor modifications based on the my specific need. I am stuck on one part: I want to copy the values and format from the source files and paste to my target workbook. As it stands, only the values are being copied. Hoping someone can take a quick look and provide guidance on how to copy over the format as well. Thanks in advance for the help.
Sub GetData_Example6()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet
Dim MyFiles() As String
Dim Fnum As Long
Dim rnum As Long
Dim destrange As Range
MyPath = "C:\Data\Test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Test"
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
'Find the last row with data
rnum = LastRow(sh)
'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")
'Get the cell values and copy it in the destrange
MyFiles(Fnum).Copy
destrange.PasteSpecial xlValues
destrange.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
GetData MyPath & MyFiles(Fnum), "Sheet1", "A1:AC5100", destrange, False, False
Next
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
I am using the following code using ADO connection to extract data from multiple workbooks without them being opened to speed up the process. I made minor modifications based on the my specific need. I am stuck on one part: I want to copy the values and format from the source files and paste to my target workbook. As it stands, only the values are being copied. Hoping someone can take a quick look and provide guidance on how to copy over the format as well. Thanks in advance for the help.
Sub GetData_Example6()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet
Dim MyFiles() As String
Dim Fnum As Long
Dim rnum As Long
Dim destrange As Range
MyPath = "C:\Data\Test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Test"
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
'Find the last row with data
rnum = LastRow(sh)
'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")
'Get the cell values and copy it in the destrange
MyFiles(Fnum).Copy
destrange.PasteSpecial xlValues
destrange.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
GetData MyPath & MyFiles(Fnum), "Sheet1", "A1:AC5100", destrange, False, False
Next
End If
CleanUp:
Application.ScreenUpdating = True
End Sub