I'm trying to paste the rows 8-18 on sheet2 and have this looping for multiple workbooks and I want the next selection to paste on the last row. For example if the lastrow is 2 to start, it should paste between 2-12 and the following workbook should paste on 13-23 and so on. The last line that refers to ("B4") I need this to on all ten lines repeating. My code doesn't seem to be working.
Sub PullAP()
Dim Source As Workbook
Dim MyDate, MyMonth
MyDate = Date
MyMonth = Month(MyDate) + 1
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lastRow As Long
'Speed up macro
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension
myExtension = "*.xls*"
'Target Path with Ending Extension
myFile = Dir(myPath & myExtension)
'Loop through each excel file in folder
Do While myFile <> ""
'Set varibale equal to open workbook
Set Source = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to the next line of code
DoEvents
'Code
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row + 1
ThisWorkbook.Worksheets("Sheet2").Range("A" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("A8:A18").Value
ThisWorkbook.Worksheets("Sheet2").Range("D" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("D8:D18").Value
ThisWorkbook.Worksheets("Sheet2").Range("E" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("E8:E18").Value
ThisWorkbook.Worksheets("Sheet2").Range("F" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("F8:F18").Value
ThisWorkbook.Worksheets("Sheet2").Range("B" & lastRow).Formula = Source.Worksheets("SUMMARY DATA SHEET").Range("B4").Value
'Close without saving
Source.Close SaveChanges:=False
'Ensure Workbook has closed before next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
MsgBox "Task Complete!"
ResetSettings:
'Resets optimization settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I believe you are trying to do this:
dim lrs as long, lrd as long, i as long
for i = 1 to workbooks(1).sheets.count
with workbooks(1).sheets(i)
lrs = .cells(.rows.count,1).end(xlup).row
.range(.cells(1,1),.cells(lrs,1)).Copy
end with
with workbooks("dest").sheets("name")
lrd = .cells(.rows.count,1).end(xlup).row
.range(.cells(lrd+1,1),.cells(lrd+1+lrs,1)).PasteSpecial xlValues
end with
next i
Untested, but should give the right idea. You will need to find and provide an entire range to paste into (last row destination + last row source + 1).
You could also value = value, like you have, but in my opinion it is harder to read/debug; using With statements makes it easier.
I had the code above looping through sheets in a workbook, but you can iterate through workbooks in a directory similarly.
Edit1:
In reading the comments and the updated post, I believe you're still working towards the use of lrd (last row on destination) +1, in the above code.
dim lrd as long, i as long, j as long
for i = 1 to workbooks(1).sheets.count
with ThisWorkbook.Sheets("Sheet2")
lrd = .cells(.rows.count,1).end(xlup).row
.range(.cells(lrd+1,1),.cells(lrd+1+10,1)).Values = Source.Sheets("SUMMARY DATA SHEET").Range(Source.Sheets("SUMMARY DATA SHEET").Cells(8,"A"),Source.Sheets("SUMMARY DATA SHEET").Cells(18,"A")).Value
do until j = (lrd+10+1)
if .Cells(lrd+1+j,1).Value = "" then .Cells(lrd+1+j,1).Value = "N/A"
loop
j = 0
end with
next i
The big addition here is to put arbitrary text into the unused cells so the last row definition will be easier. You could also eliminate the lrd by using a variable to count files, also elimnating the need to use the nested loop which fills in blank cells:
dim k as long
Do While myFile <> ""
'rest of your code using destination .range(.cells(1+k*10,1),.cells(1+10+k*10,1))
'directly before loop ends add
k = k + 1
Loop
k=0
Last note: I only showed for column 1 ("A") in my answer to demonstrate intent.
Edit2:
Declare up top:
dim k as long
Then using your existing loop, put inside like this (will need to add for the additional columns), which should only replace the section labeled 'Code:
with ThisWorkbook.Sheets("Sheet2")
.range(.cells(1+k+k*10,1),.cells(1+k+k*10+10,1)).Values = Source.Sheets("SUMMARY DATA SHEET").Range(Source.Sheets("SUMMARY DATA SHEET").Cells(8,"A"),Source.Sheets("SUMMARY DATA SHEET").Cells(18,"A")).Value
end with
Add these when closing your loop:
k = k + 1
Loop
k = 0
That should allow the k to iterate with the loop; k = 0 to start inherently, so your ranges are:
.range(.cells(1+0+0*10,1),.cells(1+0+0*10+10,1)).Values = A1 to A11 'first loop
.range(.cells(1+1+1*10,1),.cells(1+1+1*10+10,1)).Values = A12 to A22 'second loop
.range(.cells(1+2+2*10,1),.cells(1+2+2*10+10,1)).Values = A23 to A33 'third loop
Related
I have been running this code in my day to day work to keep on top of my orders and shipping, the code opens a spreadsheet in a specified location and returns the following, invoice number, company name, shipping date and total order value and puts them into one main spreadsheet.
I started using it last year and it used to take just under 3 minutes to run through about 400-500 spread sheets to collect the data. now I have a similar amount of data to run through this year but the report takes hours!!
I haven't changed my report and the data is the same data from the same template just in a different folder but in the same location on the same drive under the same parent folder.
I don't think it s the change of location that has slowed it down.
I have included a copy of my code below with notes under most of the code to explain the function of each line, can anyone see any problems with the code or recommend any improvements?
Sub Invoice_Records()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim FileExt As String
Dim CellValue As Range
Dim Text As String
Dim Text2 As String
Dim Text3 As String
Dim Total As Range
Dim filecountB As String
Dim i As String
Dim ws As Worksheet
Dim Invoice_Count As Integer
Set ws = Worksheets("Admin2")
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns(2).EntireColumn.Clear
ws.Columns(3).EntireColumn.Clear
ws.Columns(4).EntireColumn.Clear
ws.Columns(5).EntireColumn.Clear
ws.Columns(6).EntireColumn.Clear
ws.Columns(7).EntireColumn.Clear
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
filecountB = objFolder.Files.Count
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
ws.Cells(i + 1, 2) = objFile.Name
'print file path
ws.Cells(i + 1, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Path
'Get the file extension
FileExt = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, "."))
'Paste file extension in column D
ws.Cells(i + 1, 4) = FileExt
If FileExt = "xlsm" Then
'This line stops the excel documents opening on your screen they just open in the background meaning your screen does not flicker
Application.ScreenUpdating = False
Application.StatusBar = True
Application.StatusBar = "Currently processing item " + i + " out of " + filecountB
'This opens the documents
Workbooks.Open Filename:=objFile.Path
'Tells VBA what you are looking for
Text = "Total Invoice Value"
'Find text, defined in line above
Set Match = ActiveSheet.Cells.Find(Text)
'Get the value of the cell next to cell found above
findoffset = Match.Offset(, 1).Value
'Paste this value in to column F
ws.Cells(i + 1, 6) = findoffset
'Tells VBA what else to look for
Text2 = "Order No:"
'Find Text2, defined in line above
Set Index = ActiveSheet.Cells.Find(Text2)
'If "Order No:" cant be found then do below if it is found skip to ELSE
If Index Is Nothing Then
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
Else
'Paste the "Order No:" in column G
ws.Cells(i + 1, 7) = Index
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
End If
Else
'If file extension is anything other than XLSM then leave the date blank
ws.Cells(i + 1, 5) = ""
'Go onto the next file
i = i + 1
End If
Next objFile
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
Application.StatusBar = False
Call FindingLastRow
End Sub
Sub FindingLastRow()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Set ws = Worksheets("Admin2")
'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "A")
'returns the cell A1048576, ie. last cell in column A, and the code starts from this cell moving upwards;
'the code is bascially executing Range("A1048576").End(xlUp), and Range("A1048576").End(xlUp).Row finally returns the last row number.
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
ws.Range("Row_Number").Value = lastRow
End Sub
Alright, so I changed a few things and removed some unnecessary code. Here is my "changelog":
Commented out call to FindingLastRow as it currently does nothing
Moved the 'Dims' around so that they are easier to read
Removed unused variables
Added variables for the temporary workbooks
I did this to avoid using ActiveSheet which will slow code down
NOTE: The line that sets wsTemp might not work correctly, let me know if it fails
Grouped the columns.clear calls you made
Changed starting value of i to 2 for simplicity
Added range variables to catch the Range.Find("..") results
Moved Application.ScreenUpdating call outside of loop
No reason to have it toggle so frequently inside of the loop itself
Added toggle to .Calculation and .EnableEvents to potentially speed program up further
They act similarly to .ScreenUpdating by suppressing excel and speed up by focusing on only certain operations
Removed the .select for the hyperlinks
Like calling Activesheet, calling .select will also slow code down
String concatenation for StatusBar uses & instead of +
Changed around how the if statements were used to clear out duplicate code
A couple times you were repeating code in the ifs when you can just do it right after them
Re-ordered the value pasting to match the columns theyre pasted in (ie C,D,E,F,G )
When calling cells using .cells(r,c) you can actually just use the column string, so I did that for simplicity
NOTE: your comments said that 'Date' would go in column F but your actual code put it in column E, so I chose to use E
Started using .value2 and .value when accessing/pasting text into cells
NOTE: added offset to the "order no" to match your other searches (it looked like an oversight)
I think that's it???
With all that in mind, here is the result. Hopefully it scales properly with your folder now :)
Sub Invoice_Records()
Dim ws As Worksheet
Set ws = Worksheets("Admin2")
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
'Create an instance of the FileSystemObject
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Dim objFolder As Object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
Dim objFile As Object
Dim i As Long
i = 2
Dim FileExtension As String
Dim filecountB As String
filecountB = objFolder.Files.count
Dim searchInvValue As Range
Dim searchOrderNum As Range
Dim searchDate As Range
'Toggling screen updating prevents screen flicker and speeds up operations
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.StatusBar = True
End With
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns("B:G").EntireColumn.Clear
'Loops through each file in the directory
For Each objFile In objFolder.Files
'Update status bar to show progress
Application.StatusBar = "Currently processing item " & (i - 1) & " out of " & filecountB
'Paste file name
ws.Cells(i, "B").Value2 = objFile.Name
'Paste file path and add a hyperlink to it
ws.Hyperlinks.Add Anchor:=ws.Cells(i, "C"), Address:=objFile.path, TextToDisplay:=objFile.path
'Get the file extension
FileExtension = UCase$(Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")))
'Paste file extension
ws.Cells(i, "D").Value2 = FileExtension
'Only do operations on files with the extension "xlsm", otherwise skip
If FileExtension = "xlsm" Then
'This opens the current "objFile" document
Set wbTemp = Workbooks.Open(Filename:=objFile.path)
Set wsTemp = wbTemp.Sheets(1)
'Find and paste "Date:"
Set searchDate = wsTemp.Cells.Find("Date:")
ws.Cells(i, "E").value = searchDate.Offset(, 1).value
'Find and paste "Total Invoice Value"
Set searchInvValue = wsTemp.Cells.Find("Total Invoice Value")
ws.Cells(i, "F").Value2 = searchInvValue.Offset(, 1).Value2
'Find "Order No:" and paste if not blank
Set searchOrderNum = wsTemp.Cells.Find("Order No:")
If Not searchOrderNum Is Nothing Then ws.Cells(i, "G").Value2 = searchOrderNum.Offset(, 1).Value2
'Close the current "objFile" workbook
wbTemp.Close
End If
'Go onto the next file
i = i + 1
Next objFile
'Turn screen updating back on so that you can see the values being updated
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.StatusBar = False
End With
'Call FindingLastRow 'this does not currently seem necessary
End Sub
I have 100+ files in one folder. Each file has 3 lists, but only 1 list with data. I need to take that data from each file and combine it in a single file on 1 list. I wrote a sub for it, but I'm not sure how to go around selecting only the range needed (it varies from file to file) - in the same way you do it on keyboard with Ctrl + Shift + left arrow + down arrow. And how should I go around pasting it in the result workbook at exactly the first free line after the data that was pasted before?
Sub combine()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ExcelApp As Object
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
ExcelApp.ScreenUpdating = False
ExcelApp.DisplayAlerts = False
ExcelApp.EnableEvents = False
'**VARIABLES**
Dim folderPath As String
folderPath = "Y:\plan_graphs\final\mich_alco_test\files\"
'COUNT THE FILES
Dim totalFiles As Long
totalFiles = 0
Dim fileTitle As String
fileTitle = Dir(folderPath & "*.xl??")
Do While fileTitle <> ""
totalFiles = totalFiles + 1
fileTitle = Dir()
Loop
'OPENING FILES
Dim resultWorkbook As Workbook
Dim dataWorkbook As Workbook
Set resultWorkbook = ExcelApp.Application.Workbooks.Open("Y:\plan_graphs\final\mich_alco_test\result.xlsx")
fileTitle = Dir(folderPath & "*.xl??")
'FOR EACH FILE
Do While fileTitle <> ""
Set dataWorkbook = ExcelApp.Application.Workbooks.Open(folderPath & fileTitle)
dataWorkbook.Worksheets("List1").Range("A1").Select
dataWorkbook.Worksheets("List1").Selection.CurrentRegion.Select
`resultWorkbook.Range
fileTitle = Dir()
Loop
ExcelApp.Quit
Set ExcelApp = Nothing
End Sub
I may have misunderstood the question and unfortunately I cannot make a comment. If I've grasped this question wrong, i'll delete.
but I'm not sure how to go around selecting only the range needed
This suggests that you have a dynamic amount of data and want to use Range to grab the selections.
Supposing you know the column location of where said data is located (in this case my list starts at B2 and we don't know where it ends. You can use Range to dynamically select all data:
Dim rcell As Range
Dim rng As Range
Set rng = ActiveSheet.Range("B2", Range("B2").End(xlDown))
For Each rcell In rng.Cells
Debug.Print rcell.Value
Next rcell
End Sub
First we define a Range variable and assign it to the range starting at B2 and using .End(xlDown) we can select a range ending at the final entry.
For further reading on .End() see here.
Hope this helps.
You can do this without VBA. Use Get & Transform instead.
Here are a few steps to get you started:
Go to the Data Tab
Under Get & Transform, pick New Query - From File - From Folder
Select the folder containing all your 100+ files
Select the tab that contains your data
You are almost there. Do your final fixes (if needed)
Once you're done, click Close & Load
This should do what you want.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
i have this Code VBA, its works, i can combine some files on one sheet.
check it!
Sub Open_Files()
Dim Hoja As Object
Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
Workbooks.Add
'Captura nombre de archivo destino donde se grabaran los archivos seleccionados
A = ActiveWorkbook.Name
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
Workbooks.Open X(y)
b = ActiveWorkbook.Name
For Each Hoja In ActiveWorkbook.Sheets
Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
Next
Workbooks(b).Close False
Next
Application.StatusBar = "Listo"
Call Unir_Hojas
End If
Application.ScreenUpdating = False
End Sub
I was curious if anybody could provide suggestions on how I can make an excel macro more stable.
The macro prompts the user for a path to a folder containing files to scan. The macro then iterates for every file in this folder.
It opens the excel file, scans Column D for the word fail, then copies that row of data to the data sheet in the excel file where this macro is programmed.
For the most part the macro runs perfectly but sometimes I get run time errors or 'excel has stopped working' errors. I can scan through 5000+ files at a time and the macro takes a while to run.
Any suggestions would be appreciated. Thanks!
Sub findFail()
Dim pathInput As String 'path to file
Dim path As String 'path to file after being validated
Dim fileNames As String 'path to test file
Dim book As Workbook 'file being tested
Dim sheet As Worksheet 'sheet writting data to
Dim sh As Worksheet 'worksheet being tested
Dim dataBook As Workbook 'where data is recorded
Dim row As Long 'row to start writting data in
Dim numTests As Long 'number of files tested
Dim j As Long 'counter for number of files tested
Dim i As Long 'row currently being tested
Dim lastRow As Long 'last row used
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Application.ScreenUpdating = False
j = 0
i = 1
row = 2
Set dataBook = ActiveWorkbook
Set sheet = Worksheets("Data")
sheet.Range("A2:i1000").Clear
startTime = Timer
'-----Prompt for Path-----
pathInput = InputBox(Prompt:="Enter path to files. It must have a \ after folder name.", _
Title:="Single Report", _
Default:="C:\Folder\")
If pathInput = "C:\Folder\" Or pathInput = vbNullString Then 'check to make sure path was inputed
MsgBox ("Please enter a valid file path and try again.")
Exit Sub
Else
path = pathInput 'path = "C:\Temp\212458481\" ' Path for file location
fileNames = Dir(path & "*.xls") 'for xl2007 & "*.xls?" on windows
'-----begin testing-----
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
lastRow = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).row
If sh.Cells(lastRow, 2).Value - sh.Cells(1, 2).Value >= 0.08333333 Then
Do While sh.Range("D" & i).Value <> "" 'loop untile there are no rows left to test
If sh.Range("D" & i).Value = "Fail" Then 'record values if test result is false
sheet.Range("A" & row).Value = book.Name
sheet.Range("B" & row).Value = Format(sh.Range("B" & i).Value - sh.Range("B1").Value, "h:mm:ss")
sheet.Range("C" & row).Value = sh.Range("A" & i).Value
sheet.Range("D" & row).Value = Format(sh.Range("B" & i).Value, "h:mm:ss")
sheet.Range("E" & row).Value = sh.Range("C" & i).Value
sheet.Range("F" & row).Value = sh.Range("D" & i).Value
sheet.Range("G" & row).Value = sh.Range("E" & i).Value
sheet.Range("H" & row).Value = sh.Range("F" & i).Value
sheet.Range("I" & row).Value = sh.Range("G" & i).Value
row = row + 1
Exit Do
End If
i = i + 1
Loop
j = j + 1
dataBook.Sheets("Summary").Cells(2, 1).Value = j
End If
book.Close SaveChanges:=False
fileNames = Dir()
i = 1
Loop
numTests = j
Worksheets("Summary").Cells(2, "A").Value = numTests
minsElapsed = Timer - startTime
Worksheets("Summary").Cells(2, "B").Value = Format(minsElapsed / 86400, "hh:mm:ss")
End If
End Sub
Without the same dataset as you we, can not definitively supply an answer but I can recommend the below which is related to the error you are seeing.
Try freeing/destroying the references to book and sh.
You have a loop that sets them:-
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
However the end of the loop does not clear them, ideally it should look as below:-
Set sh = Nothing
Set book = Nothing
Loop
This is a better way to handle resources and should improve memory usage.
As a poor example, without it your code is saying, sh equals this, now it equals this instead, now it equals this instead, now it equals this instead, etc...
You end up with the previous reference that was subsequently overwritten being a sort of orphaned object that is holding some space in memory.
Depending on your case, you may use the following to make it faster -by turning off excel processes that you don't really need at the time of your macro execution-
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.StatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
End Sub
In your sub
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Call ExcelBusy
...
As a comment, you never set back screenupdating to true in your sub, that may lead to strange behavior in excel, you should turn everything to default after you are done with your stuff.
OT: Some processes can't be optimized any further -sometimes-, by what you are saying -scanning over 5k files?- surely it's going to take a time, you need to work in how to communicate the user that is going to take a while instead -perhaps an application status bar message or a user form showing process?-.
I am a new programmer and I am trying to find a way to extract one range of data from multiple workbooks and copy them into a master file. I have already wrote the code to do this below, but the problem that I am having is that my code physically opens the xlsm files > copies the data > then goes back into the master file to paste. Since this is being done to thousands of files at once, it takes hours to complete. My boss told me there is a way to copy the data from the xlsm files without having the code actually open the file if it is read as xml or as a .txt file. I have searched online for this, but cannot find anything on how this would be done. Any help would be greatly appreciated.
The code I have that physically opens the workbooks:
Option Explicit
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim FileType As String
Dim FilePath As String
FileType = "*.xlsm*" 'The file type to search for
FilePath = "C:\Users\hasib\xlsm's\" 'The folder to search
Dim src As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
OutputCol = 9 'The first row of the active sheet to start writing to
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FilePath & Curr_File, True, True)
Sheets("Reporting").Range("I7:I750").Copy
Workbooks("Master.xlsm").Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(4, OutputCol).Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
OutputCol = OutputCol + 1
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Curr_File = Dir
Loop
Set src = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I found out that there is a formula you can use in a cell that will pull in data from a closed workbook. If you type ='folderpath[filename]Sheetname'Cell into a cell it will automatically pull in that information. Using this logic I created the below to loop through all my files and paste data into my workbook from the files being called:
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "c:\"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
FilePath = fd.SelectedItems(1)
FolderPath = Left(FilePath, InStrRev(FilePath, "\"))
If FileChosen = -1 Then
'open each of the files chosen
For c = 1 To fd.SelectedItems.count
FileName = Dir(fd.SelectedItems(c))
ThisWorkbook.Sheets("Batch Results").Cells(OutputRow, OutputCol).Formula = "='" & FolderPath & "[" & FileName & "]Reporting'!$I7"
OutputCol = OutputCol + 1
Next c
End If
ThisWorkbook.Sheets("Batch Results").Select
Cells(1, OutputCol).Select
EndColumn = Split(ActiveCell(1).Address(1, 0), "$")(0)
RangeName = ("A1:" & EndColumn & "1")
Range(RangeName).Select
Selection.AutoFill Destination:=Range("A1:" & EndColumn & "558"), Type:=xlFillDefualt
I have exhausted my search capabilities looking for a solution to this. Here is an outline of what I would like to do:
User opens macro-enabled Excel file
Immediate prompt displays for user to enter or select file path of desired workbooks. They will need to select two files, and the file names may not be consistent
After entering the file locations, the first worksheet from the first file selection will be copied to the first worksheet of the macro-enabled workbook, and the first worksheet of the second file selection will be copied to the second worksheet of the macro-enabled workbook.
I've come across some references to ADO, but I am really not familiar with that yet.
Edit: I have found a code to import data from a closed file. I will need to tweak the range to return the variable results.
Private Function GetValue(path, file, sheet, ref)
path = "C:\Users\crathbun\Desktop"
file = "test.xlsx"
sheet = "Sheet1"
ref = "A1:R30"
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub TestGetValue()
path = "C:\Users\crathbun\Desktop"
file = "test"
sheet = "Sheet1"
Application.ScreenUpdating = False
For r = 1 To 30
For C = 1 To 18
a = Cells(r, C).Address
Cells(r, C) = GetValue(path, file, sheet, a)
Next C
Next r
Application.ScreenUpdating = True
End Sub
Now, I need a command button or userform that will immediately prompt the user to define a file path, and import the data from that file.
I don't mind if the files are opened during process. I just didn't want the user to have to open the files individually. I just need them to be able to select or navigate to the desired files
Here is a basic code. This code asks user to select two files and then imports the relevant sheet into the current workbook. I have given two options. Take your pick :)
TRIED AND TESTED
OPTION 1 (Import the Sheets directly instead of copying into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 1"
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Copy After:=wb1.Sheets(1)
ActiveSheet.Name = "Blah Blah 2"
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
OPTION 2 (Import the Sheets contents into sheet1 and 2)
Option Explicit
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim Ret1, Ret2
Set wb1 = ActiveWorkbook
'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select first file")
If Ret1 = False Then Exit Sub
'~~> Get the 2nd File
Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select Second file")
If Ret2 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells
wb2.Close SaveChanges:=False
Set wb2 = Workbooks.Open(Ret2)
wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wb1 = Nothing
End Sub
The function below reads data from a closed Excel file and returns the result in an array. It loses formatting, formulas etc. You might want to call the isArrayEmpty function (at the bottom) in your main code to test that the function returned something.
Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant
'see http://www.ozgrid.com/forum/showthread.php?t=19559
'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function
Dim locConnection As New ADODB.Connection
Dim locRst As New ADODB.Recordset
Dim locConnectionString As String
Dim locQuery As String
Dim locCols As Variant
Dim locResult As Variant
Dim i As Long
Dim j As Long
On Error GoTo error_handler
locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & parExcelFileName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES"";"
locQuery = "SELECT * FROM [" & parSheetName & "$]"
locConnection.Open ConnectionString:=locConnectionString
locRst.Open Source:=locQuery, ActiveConnection:=locConnection
If locRst.EOF Then 'Empty sheet or only one row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet
ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant
For i = 1 To locRst.Fields.Count
locResult(1, i) = locRst.Fields(i - 1).Name
Next i
Else
locCols = locRst.GetRows
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''' FIX: an empty sheet returns "F1"
'''''' http://support.microsoft.com/kb/318373
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet
ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant
If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen
For j = 1 To UBound(locResult, 2)
locResult(1, j) = locRst.Fields(j - 1).Name
Next j
For i = 2 To UBound(locResult, 1)
For j = 1 To UBound(locResult, 2)
locResult(i, j) = locCols(j - 1, i - 2)
Next j
Next i
End If
locRst.Close
locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
getDataFromClosedExcelFile = locResult
Exit Function
error_handler:
'Wrong file name, sheet name, or other errors...
'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error
If locRst.State = ADODB.adStateOpen Then locRst.Close
If locConnection.State = ADODB.adStateOpen Then locConnection.Close
Set locRst = Nothing
Set locConnection = Nothing
End Function
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Sample use:
Sub test()
Dim data As Variant
data = getDataFromClosedExcelFile("myFile.xls", "Sheet1")
If Not isArrayEmpty(data) Then
'Copies content on active sheet
ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data
End If
End Sub