Copy and Paste across Folders in a loop with VBA - excel

I am trying to write a loop that copies and pastes a range of data from one workbook to another. I get stuck with the error 'Select Sheet method not proper' or whatever the error message is. This is what I have so far:
folderpath="insert folder path here"
Filename = Dir(folderPath)
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename)
wb.Worksheets("Outcomes & Factors Rankings").Select
Range("A3", Range("A3").End(xlDown).Offset(0, 6)).Copy
ThisWorkbook.Worksheets("OutcomeFactorRankings").Select
Range("A1").End(xlDown).Offset(1, 0).Select.Paste
wb.Close
Loop

Try to indent your code, you don't need all those selects in your code, simplify, something like that should solve your problem:
folderPath = "insert folder path here"
Filename = Dir(folderPath)
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename)
wb.Worksheets("Outcomes & Factors Rankings").Range("A3", Range("A3").End(xlDown).Offset(0, 6)).Copy
ThisWorkbook.Worksheets("OutcomeFactorRankings").Range("A1").End(xlDown).Offset(1, 0).Paste
wb.Close
Loop

Related

Save file path according to worker matric number vba

I would like to save file in a "CONSOLIDATE FOLDER". But the file path should depend on staff working number ID (00639) where they input it in the "TEMPLATE" worksheet cell "N3". And in case staff forgot to input their working ID, there'll be a pop up box telling them to fill in their ID.
Any help really appreciated.
Sub MergeFile ()
Dim WB As Workbook
Dim WS as Worksheet
Dim FileName as String
Dim FilePath as String
Set WB = Workbook.Add
FilePath = "C:\Users\KGA00639\Desktop\CONSOLIDATE FOLDER"
FileName = ThisWorkbook.Worksheets("TEMPLATE").Range("L15").Value
For Each WS in ThisWorkbook.Worksheets
If WS.Name <> "TEMPLATE" Then
WS.Copy before:=WB.Sheets(1)
End if
If FileName = "" Then
FileName = InputBox ("You did not name the workbook" & vbCrLf & _
"Please write the name and press OK.:,"Setting the workbook name")
If FileName = "" Then Exit sub
ThisWorkbook.Worksheets("TEMPLATE").Range("L15").Value = FileName
End If
Next
ActiveWorkbook.SaveAs FileName:=FilePath & "\" & FileName
MsgBox ("Done"!)
ActiveWorkbook.Close
End Sub
This solution should come rather close to what you want. Please take a look.
Sub MergeFile()
' 056
Dim Wb As Workbook
Dim Ws As Worksheet
Dim FileName As String
Dim FilePath As String
Dim UserID As String
With ThisWorkbook.Worksheets("TEMPLATE")
UserID = .Cells(1, "A").Value ' change address to suit
FileName = .Range("L15").Value
If Left(UserID, 2) <> "ID" Then
MsgBox "You must enter your valid user ID in" & vbCr & _
"cell A1 of the 'Template' tab." & vbCr & _
"This program will now be terminated.", _
vbInformation, "Incomplete preparation"
.Activate
.Cells(1, "A").Select ' change to match above
Exit Sub
End If
End With
Application.ScreenUpdating = False
' use the UserID variable in whichever way you wish
FilePath = Environ("UserProfile") & "\" & UserID & "\Desktop\CONSOLIDATE FOLDER"
Set Wb = Workbooks.Add
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "TEMPLATE" Then
Ws.Copy Before:=Wb.Sheets(1)
End If
Next Ws
Wb.SaveAs FilePath & FileName, xlOpenXMLWorkbook
Application.ScreenUpdating = True
End Sub
You didn't specify where on the 'Template' tab the user ID would be found. The above code looks for it in cell A1. That cell is mentioned in 3 locations in the code (once in the message text). Please modify the code to match your facts.
You also didn't say where the UserID should appear in the FilePath. I placed it before the Desktop. I'm sure you will know how to amend that bit of code to suit you better.
When saving the workbook my code specifies an xlsx format. If this isn't what you want change the file format constant in the SaveAs line. I didn't think it a good idea to specify the extension in the 'Template'. You may like to move it to the code.
Finally, you didn't specify the next step after creation of the new workbook. So the code ends in the middle of nowhere. Excel made the new workbook the active one but you may like to close it, or ThisWorkbook, and determine what to do with the blank worksheet(s) still contained in the new book. There are a lot of lose ends still to tidy up. Good luck!

SaveAs Nonstop Loop

To get to the point of completion for my macro, I start with a downloaded file from the internet which downloads as .xls. After downloading it, I then need to save the file as a .xlsx and change the name of the document to be "dockactivity".
This is a macro that multiple people on multiple devices would be using so I need to keep Environ$("username") parts. (Unless that written wrong of course..)
This is a macro I use everyday for my job so I wanted to try and have it delete the original downloaded as well.
The problem I am running into:
It seems to get stuck in an endless loop of saving the file, closing it, opening it, etc.
Here is what I have in now (everything that is before the more cosmetic changes are done to the file). Please note that I am quite a novice at this type of stuff and have pieced together this code from multiple sources online/this site.
Sub dockactivity()
'
' dockactivity Macro
'
' push button to run
'
Dim Filename, Pathname, SaveFileName As String
Dim wb As Workbook
Dim UserName As String
UserName = Environ("username")
Pathname = "C:\Users\" & Environ$("username") & "\Downloads\"
Filename = Dir(Pathname & "Dock_Activity_*.xls")
Application.DisplayAlerts = False
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
wb.CheckCompatibility = True
Application.DisplayAlerts = False
wb.SaveAs Filename:="dockactivity", FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
Filename = Dir(Pathname & "Dock_Activity_*.xls")
Loop
Application.DisplayAlerts = True
If Dir(Pathname & "Dock_Activity_*.xls") <> "" Then
Kill (Pathname & "Dock_Activity_*.xls")
End If
Workbooks.Open (Pathname & "dockactivity.xlsx")
Windows("dockactivity.xlsx").Activate
Thanks for any help provided.

How to copy data from only the new excel files that are saved in a predefined folder?

I want to copy specific range from excel files stored in a specific folder and paste it in another excel file.I am able to do so.However,every time i run the code it starts with the very first file in the folder.I want to copy data from only the files that haven't been updated before.Is there a way to do that?
EG:
"file1.xlsx" and "file2.xlsx" are in a folder. I want to copy data from the given files and paste it in "NewFile.xlsm" (I'm able to achieve this) However, if I add "file3.xlsx" and "file4.xlsx" in the folder and then run the macro, it copies data from "file1.xlsx" and "file2.xlsx" as well.I want it to copy data only from "file3.xlsx" and "file4.xlsx" this time as the data from previous 2 files is already saved.
(The code i have is given below)
Path = "C:\Users\National\Desktop\TEST Codes\PO\Excel\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
If Filename = "Z master for PO.xlsm" Then
Exit Sub
End If
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Sheets("DETAILED").Range("A3:S15").Copy
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Close
Dim LASTROW As Long, WS As Worksheet, LS As Long
Set WS = Sheets("sheet1")
LASTROW = WS.Range("R" & Rows.Count).End(xlUp).Row + 1
WS.Range("A" & LASTROW).Select
ActiveSheet.Paste Destination:=WS.Range("A" & LASTROW)
Application.CutCopyMode = False
Filename = Dir()
Loop
Range("A7").Select
One way of doing this is by looking at the DateLastAccessed property, or the DateLastModified property. These are both properties of the File object, see this MS documentation.
You can set a minimum date/time, which should exclude the files you don't want processed.
Be sure to set the correct reference
Option Explicit
Sub GoThroughFiles()
Dim Path As String, Filename As String,
Dim fso, fileinfo
Set fso = CreateObject("Scripting.FileSystemObject")
Path = "C:\Users\National\Desktop\TEST Codes\PO\Excel\"
Filename = Dir(Path & "*.xls")
Set fileinfo = fso.GetFile(Path & Filename)
Do While Len(Filename) > 0
If fileinfo.DateLastAccessed > DateAdd("n", -5, Now) 'If the file was last accessed less than 5 minutes ago
'Do stuff with the file
End If
FileName = Dir()
Loop
End Sub
Furthermore, avoid using Select and Activate as using both will make your code prone to errors. Here is a thread on how to avoid it. Next to that, I added Option Explicit which makes sure you avoid other errors caused by, for example, spelling mistakes.

Excel rebooting while copying sheets from multiple books

I built a program to copy sheet one from all books in a directory, and paste them into the active workbook. I have roughly 1200 books in the directory, and without fail each time I run it excel reboots after around #125. No error messages. Anyway of getting around this?
Sub GetSheets()
Path = "C:\Users\bdaly\Desktop\Formulas\smaller sample\"
Dim DestWB As Workbook
Set DestWB = ThisWorkbook
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Sheets("Sheet1").Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Application.DisplayAlerts = False
Workbooks(Filename).Close
Application.DisplayAlerts = True
Filename = Left(Left(Filename, Len(Filename) - 4), 31)
DestWB.Sheets(DestWB.Sheets.Count).Name = Filename
Filename = Dir()
Loop
End Sub
Edit: As advised I removed the offending file, Excel still reboots after 124 loops.
Not sure if this is going to address the problem at hand, but it will help in debugging or exposing the problem.
Put simply, qualify your source data.
Include Dim SourceWB as Workbook. This could be done where you declare DestWB.
Change Workbooks.Open Filename:=Path & Filename, ReadOnly:=True to Set SourceWB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True, Editable:=True)
Change Sheets("Sheet1").Copy After:=DestWB.Sheets(DestWB.Sheets.Count) to SourceWB.Sheets("Sheet1").Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Change Workbooks(Filename).Close to SourceWB.Close
Unfortunately, the .Copy command is a Sub, not a Function - would be so much more neater if it provided a reference to the sheet that has just been created as you could then use it in DestWB.Sheets(DestWB.Sheets.Count).Name = Filename
I suggest, for debugging purposes, keeping the DisplayAlerts on for now. This may provide a clue as to where the fault is happening.
Also include some debug.print lines in your loop. Finding where in the loop it crashes could help diagnose the issue. Make them a little descriptive, the ones I would think of are:
debug.print "Entered loop"
debug.print "Copied file"
debug.print "renamed file"
'debug.print "new FileName is " & FileName`.
You get the idea.
Try the AddIn from the link below.
https://www.rondebruin.nl/win/addins/rdbmerge.htm

VBA looping through files that meet two criteria

Below is working code that is looping through files in a folder based on a user's search criteria. The folder will grow throughout the year to over 1000 files, so rather than looping through all of them every time the macro runs, I would like to add a second criteria that compares the time stamps on the files to a time stamp saved on the file as the last time it was run. LastUpdateDate is set up as variable in date format at the top of the module, and the old timestamp is saved to it at the beginning of the code.
I tried this but it left me with a run time error. Is this doable using Do While, or is there another format I need to be looking at? I also tried nesting the date comparison as an if statement under the Do While, but came up with other errors.
Do While FileName <> "" and FileDateTime(FileName) > LastUpdateDate
Working code from this section:
FileName = Dir(FolderName & "*" & MyCriterion & "*" & ".xl??")
'Loop through all matching files
Do While FileName <> ""
'Open the next matching workbook
Workbooks.Open (FolderName & FileName)
Sheets("Report Data").Select
'Call GrabTheData
GrabTheData
'Close the workbook
Workbooks(FileName).Close savechanges:=False
'Get the name of the next match in folder
FileName = Dir
Loop
End Sub
Two things:
FileDateTime
FileDateTime requires the full file path, not just the file name
Loops and Conditions
Do While (condition) stops execution of the block when (condition) is no longer true.
That is, it will stop execution as soon as (condition) is false. I don't believe this is the intended behavior.
Put an If (condition) block within the loop itself. This will loop through every workbook that matches MyCriterion, but only operate on those that match (condition).
Example (with recommendations)
Sub GrabAllData(ByVal FolderName As String, ByVal MyCriterion As String)
Dim FileName As String
Dim LastUpdateDate As Date
Dim wb As Workbook
LastUpdateDate = ThisWorkbook.Worksheets("Parameters").Range("LastUpdateDate").Value 'Named Range called LastUpdateDate on sheet "Parameters" in ThisWorkbook
'Make sure FolderName ends in a backslash
If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
'Get matching files for MyCriterion
FileName = Dir(FolderName & "*" & MyCriterion & "*" & ".xl??")
'Loop through all matching files
Do While FileName <> ""
If FileDateTime(FolderName & FileName) > LastUpdateDate Then 'FileDateTime requires the full file path, not just the file name
'Open the next matching workbook - work with the workbook directly, rather than working with ActiveWorkbook, ActiveSheet and Selections
Set wb = Workbooks.Open(FileName:=FolderName & FileName, ReadOnly:=True)
'Call GrabTheData on the workbook
GrabTheData wb
'Close the workbook
wb.Close SaveChanges:=False
End If
'Get the name of the next match in folder
FileName = Dir
Loop
Set wb = Nothing
End Sub
Sub GrabTheData(ByRef wb As Workbook)
Dim wsOut As Worksheet, wsIn As Worksheet
Set wsOut = ThisWorkbook.Worksheets("Aggregated Data") 'Worksheet called "Aggregated Data" in ThisWorkbook
Set wsIn = wb.Worksheets("Report Data")
' ### Manipulate the data and write to wsOut, no need to work with Selections ###
End Sub

Resources