VBA Open multiple files in selection to copy into mastersheet - vba

I created a macro in VBA (excel) to open a specific range of a daily file which all have a similar start of the name (9489) followed by a file specific date (DD-MM-YY). The selection is then copied into the masterfile (Masterfile.xlsm), this sub is run for all the files from the directory.
Since today however I keep getting an error named "Run-time error 1004: 9489 150116 Daily Dashboard.xlsx could not be found. Check the spelling of the file name, and verify that the file location is correct."
Why do I get this error? Most importantly, can anybody help me solve this error? I did not change the spelling of the file or the files location!
The code:
Sub LoopThroughDirectory()
Dim Myfile As String
Dim erow
Myfile = Dir("F:\WGD\Dep 408101-Se-DCIFINK-009786\Consolidatie & Regulatory Reporting\Regulatory Reporting\Daily dashboard of Ratios\Test Daily Dashboard\")
Application.DisplayAlerts = False
Do While Len(Myfile) > 0
If Myfile = "Masterfile.xlsm" Then
Exit Sub
End If
Workbooks.Open (Myfile)
Worksheets("Liquidity Reporting").Range("A2:E19").Copy
Windows("Masterfile.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 5))
Workbooks(Myfile).Application.CutCopyMode = False
Workbooks(Myfile).Close SaveChanges:=False
Myfile = Dir
Loop
End Sub

The reason that Excel cannot find the file is that MyFile is just the filename; you need to also include that file path.
This line: ActiveSheet.Paste Destination... will throw an error.
Try to avoid select and activate.
There is no need to size a range when using copy and paste. You just need to target the top left cell of the destination range.
Sub LoopThroughDirectory()
Const FOLDERPATH = "F:\WGD\Dep 408101-Se-DCIFINK-009786\Consolidatie & Regulatory Reporting\Regulatory Reporting\Daily dashboard of Ratios\Test Daily Dashboard\"
Dim Myfile As String
Dim Source As Range, Target As Range
Myfile = Dir(FOLDERPATH)
Application.DisplayAlerts = False
Do While Len(Myfile) > 0
If Myfile <> "Masterfile.xlsm" Then
With Worksheets("Sheet1")
Set Target = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
End With
With Workbooks.Open(FOLDERPATH & Myfile)
Set Source = .Worksheets("Liquidity Reporting").Range("A2:E19")
Source.Copy Destination:=Target
.Close SaveChanges:=False
End With
End If
Myfile = Dir
Loop
End Sub

Related

Copy and Paste VALUES from multiple workbooks to a worksheet in another workbook / Paste Value within Loop

The heavy lifting of this problem has already been solved here:
Copy and paste data from multiple workbooks to a worksheet in another Workbook
After adapting the code, I got everything to work perfectly in about 15 minutes. However, I then spent the past 3 hours scouring stackoverflow and the rest of the internet trying to figure out how to get it to paste VALUES ONLY instead of bringing over the formatting and formulas with it.
I've tried using .PasteSpecial xlPasteValues, but every time I try this I get an error that says "Compile Error: Expected: end of statement"
I've also tried using .PasteSpecial(xlPasteValues), I get an error that says "Run-time error '1004': Unable to get the PasteSpecial property of the Range class"
My concern is that neither of these methods will work since there wasn't even a .Paste function to begin with.
So when I tried to just add .Paste, it gives me a "Run-time error '438': Object doesn't support this property or method"
Here's the whole code, but I'm mainly just trying to figure out how to do exactly the same with except pasting VALUES ONLY. Thanks!
Sub ConsolidateAllOrdenes()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Choose Target Folder Path"
.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 (must include wildcard "*")
myExtension = "*.xlsm*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = Workbooks.Open("C:\Consolidado\Consolidado_2018-09-05a.xlsm")
Set ws2 = y.Sheets("Consolidado_Orden")
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Copy data on "Orden de Compras" sheet to "consolidado_orden" Sheet in other workbook
With wb.Sheets("Orden de Compras")
lRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("A5:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "I hope that worked!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Replace your copy/paste with this:
With wb.Sheets("Orden de Compras")
Range("A2:M" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Sorry, I'm new to this, but I think I finally figured it out. I believe the range with the copy was lacking a defined workbook and sheet.
Once I specified the workbook and sheet for the copy, there was no issue with putting the paste range on another line and adding .PasteSpecial Paste:=xlPasteValues.
I was also copying 2 lines from each workbook that didn't actually have anything, so I added If WorksheetFunction.CountA(wb.Sheets("Orden de Compras").Range("C5:C200")) <> 0 Then and later Else and End If to skip that workbook if it didn't have anything within the range C5:C200.
I also added Application.CutCopyMode = False because a message box kept popping up after each file.
Replace the copy/paste with this:
With wb.Sheets("Orden de Compras")
If WorksheetFunction.CountA(wb.Sheets("Orden de Compras").Range("C5:C200")) <> 0 Then
lRow = .Range("C" & Rows.Count).End(xlUp).Row
wb.Sheets("Orden de Compras").Range("A5:M" & lRow).Copy
ws2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Else
End If
End With
Thanks to everyone and especially #GMalc for the help!!!

Sub or function error

I am new to vba, I want to transfer data from multiple sheets in one folder to one sheet. I wrote the programme as follows:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
MyFile = Dir("C:\Bulletinwork\")
Do While Len(MyFile) > 0
If MyFile = "Bmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (MyFile)
Range("A4:I42").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 9))
MyFile = Dir
Loop
End Sub
Can someone help me find the reason why when I try to run the programme, I get an error message saying "sub or function not defined".
Kenny
The following line will be causing some grief:
Workbooks.Open (MyFile)
The () means that VBA is trying to evaluate MyFile before running the Open command. Of course, MyFile is a string/path so can't run.
Try
Workbooks.Open MyFile
instead.

Excel macro run time 1004 document may be read-only

I was attempting to extract data from other workbooks into a master workbook. All of these workbooks were saved in one folder. Besides, before extracting the data it would check the number of files in the folder. If there is only one file and it is the master workbook then it will stop and exit sub.
However, when I ran the macro it got stuck in the "Do while" loop. Then it says it has a run time error 1004, document may be read-only or encrypted1.
I am sure the path is correct.
Below is my code.
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Users\uidq3022\Desktop\Backup_Version2.0_7_12\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Import Info.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Range("F9,F12,F15,F19,F21").Select
Range("F21").Activate
ActiveWindow.SmallScroll Down:=9
Range("F9,F12,F15,F19,F21,F27,F30,F33,F37").Select
Range("F37").Activate
ActiveWindow.SmallScroll Down:=9
Range("F9,F12,F15,F19,F21,F27,F30,F33,F37,F41").Select
Range("F41").Activate
ActiveWindow.SmallScroll Down:=-27
Range("F9,F12,F15,F19,F21,F27,F30,F33,F37,F41,F6").Select
Range("F6").Activate
Selection.Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 11))
MyFile = Dir
Loop
End Sub
And my questions are,
I don't know where I went wrong with the "Do while" loop
How to fix the run time 1004 error.
Can someone give me advise? Thanks a lot!
Seems to me you're using the loop to open the files instead of doing it manually yourself. Not sure why the loop got stuck unless you had the MyFile = Dir line missing or commented out at runtime.
#Thomas is mostly right, the 1004 error is happening because the source workbook is being closed too early. However, I was able to paste the values using wkbTarget.worksheets(1).paste but it pasted all cells between F6 through F41 - not what you want.
Additionally, your copy range is 11 rows, 1 column but you're specifying a destination range of 1 row, 11 columns: Cells(erow, 1), Cells(erow, 11) . If that's what you really want, you should use Transpose. Using Cells(#,#) inside Range() also produced 1004 errors, but Cells(#,#).address resolved it.
Here's my take:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim wkbSource as Workbook
Dim wkbTarget as Workbook
Dim erow as single
Dim Filepath As String
Filepath = "C:\Users\uidq3022\Desktop\Backup_Version2.0_7_12\"
MyFile = Dir(Filepath)
Set wkbTarget = Workbooks(MyFile) 'Assuming the file is already open
Do While Len(MyFile) > 0
If MyFile = "Import Info.xlsm" Then Goto NextFile 'Skip the file instead of exit the Sub
Set wkbSource = Workbooks.Open (Filepath & MyFile) 'Set a reference to the file being opened
wkbSource.worksheet(1).Range("F9,F12,F15,F19,F21,F27,F30,F33,F37,F41,F6").Select
Selection.Copy
erow = wkbTarget.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wkbTarget.Worksheets("Sheet1").Paste Destination:=wkbTarget.Worksheets("Sheet1").Range(Cells(erow, 1).address)
wkbSource.Close
NextFile:
MyFile = Dir
Loop
End Sub
Thomas's single-line copy+paste technique is nicely concise. You could rearrange the lines of code to use that approach, I just recommend making the Source and Target objects clear.

Copying data from many workbooks to a summary workbook with Excel-VBA. Run time errors

I have files in a folder and I want to copy data from these files and paste them into another Master workbook sheet.
I keep getting a runtime error ‘1004’: Sorry we couldn’t find C:\Users\jjordan\Desktop\Test Dir\MASTER`, It is possible it was moved, renamed or deleted.
The error is highlighted on this line of code: Workbooks.Open SumPath & SumName
I have seen other questions similar to this on the web, I have tried making various changes. But still without success. Please advise.
Dir for source files: C:\Users\ jjordan \Desktop\Test Dir\GA Test\
Dir for Master file: C:\Users\ jjordan \Desktop\Test Dir\MASTER\
Source filenames differ, but all end in "*.xlsx."
Master filename: " MASTER – Data List - 2016.xlsm " ‘macro file
Source worksheet name = "Supplier_Comments"
Master worksheet name = "Sheet5"
Option Explicit
Sub GetDataFromMaster()
Dim MyPath As String
Dim SumPath As String
Dim MyName As String
Dim SumName As String
Dim MyTemplate As String
Dim SumTemplate As String
Dim myWS As Worksheet
Dim sumWS As Worksheet
'Define folders and filenames
MyPath = "C:\Users\jjordan\Desktop\Test Dir\GA Test\"
SumPath = "C:\Users\jjordan\Desktop\Test Dir\MASTER\"
MyTemplate = "*.xlsx" 'Set the template.
SumTemplate = "MASTER – Data List - 2016.xlsm"
'Open the template file and get the Worksheet to put the data into
SumName = Dir(SumPath & SumTemplate)
Workbooks.Open SumPath & SumName
Set sumWS = ActiveWorkbook.Worksheets("Sheet5")
'Open each source file, copying the data from each into the template file
MyName = Dir(MyPath & MyTemplate) 'Retrieve the first file
Do While MyName <> ""
'Open the source file and get the worksheet with the data we want.
Workbooks.Open MyPath & MyName
Set myWS = ActiveWorkbook.Worksheets("Suppliers_Comment")
'Copy the data from the source and paste at the end of sheet 5
myWS.Range("A2:N100").Copy
sumWS.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
'Close the current sourcefile and get the next
Workbooks(MyName).Close SaveChanges:=False 'close
MyName = Dir 'Get next file
Loop
'Now all sourcefiles are copied into the Template file. Close and save it
Workbooks(SumName).Close SaveChanges:=True
End Sub
Here is a template for what you'd like done. NOTE that forward slashes can cause run time error b/c vba handles them in an annoying way.
Sub DougsLoop()
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False 'these three statements help performance by disabling the self titled in each, remeber to re-enable at end of code
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer 'Starts timer to see how long code takes to execute. I like having this in macors that loop through files
path = "C:\Users\jjordan\Desktop\Test Dir\GA Test" & "\" 'pay attention to this line of code********
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet5")
Do While Len(Filename) > 0 'this tells the code to stop when there are no more files in the destination folder
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
For Each sheet In ActiveWorkbook.Worksheets
Set rRng = sheet.Range("a2:n100")
For Each rCell In rRng.Cells
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell
Next rCell
Next
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
alter to this to your needs and you'll find it works perfectly :)
EDIT: Also in your code you make use of COPY & PASTE a lot. Try avoid doing this in the future. Try doing something:
ThisWorkbook.Sheets("Sheet1").Range("a1").Value = OtherWork.Sheets("Sheet1").Range("a1").Value
This is more efficient and wont bog down your code as much.
here is some offset logic
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value =
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 1).Value =
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 2).Value =
notice the Offset(x,y) value? Essentially x is down and y is right. this is of course referencing the original position. So to get a value to go in the same row but three columns over you would use "Offset(0,3)" etc etc
Ill let you alter your code to do this. :)
I guess actually trying to piece it together was a struggle? Here this version assumes the macro is in the master workbook(and that youre running it form the master). If you want to change go ahead, but this is as far as I go. At some point, you'll have to experiment on your own.

Copy & Transpose Values from 1 Workbook to Another

Sub LoopThroughDecTab()
Dim MyFile As String
Dim erow
Dim FilePath As String
FilePath = "C:"
MyFile = Dir(FilePath)
Do While Len(MyFile) > 0
If MyFile = "Dec Tab Macro.xlsm" Then
Exit Sub
End If
Workbooks.Open (FilePath & MyFile)
ActiveWorkbook.Worksheets("Declaration Analysis (Source)").Activate
Range("H9:H21").Copy
ActiveWorkbook.Close False
'Getting Runtime error PasteSpecialMethod of Range Failed on following line'
ActiveSheet.Range(Cells(erow, 1), Cells(erow, 7)).PasteSpecial.Range Transpose:=True
MyFile = Dir
Loop
End Sub
I have files in a folder, the code loops through the files copies values and then I want those values Transposed into the Active MasterSheet. There are 7 values that need to be pasted, and then it should open the next workbook in folder and repeat the process.
Assuming that you posted your complete code, and simply interjected the 'non-code' message to tell us where your error was, give this a try:
Option Explicit
Sub LoopThroughDecTab()
Dim MyFile As String
Dim erow
Dim FilePath As String
Dim DestWB as Workbook
Dim SourceWB as Workbook
'this way we know the one where the code is running and the destination for our copies
set DestWB = ThisWorkbook
FilePath = "C:"
MyFile = Dir(FilePath)
Do While Len(MyFile) > 0
If MyFile = "Dec Tab Macro.xlsm" Then
Exit Sub
End If
Set SourceWB = Workbooks.Open (FilePath & MyFile)
SourceWB.Worksheets("Declaration Analysis (Source)").Range("H9:H21").Copy
'Move the close to AFTER you do the paste
'NOTE: You may have to make a change here:
DestWB.Range(Cells(erow, 1), Cells(erow, 7)).PasteSpecial.Range Transpose:=True
SourceWB.Close False
MyFile = Dir
Loop
End Sub
If you open two workbooks (A & B) in Excel, copy some cells from A, close A, then try to paste into B, you'll have nothing left to paste - closing A clears the clipboard buffer. I believe the same thing is happening here.
Important Notes:
I've removed all references to ActiveWorkbook - I believe that I've gotten it correct, but I always get a bit lost when using Active*, so I avoid it at all cost. (There are a very few situations where it's the only way to get things done, this isn't one of them.) If I've messed up your source & destinations for the copy, simply reverse the Set statements so you're using them the other way.
I'm not sure where erow and FilePath are getting set, so I'm assuming this wasn't the complete code. The assumption is that they'll still get set somehow.
I've not used the copy/transpose function, so you may well need to include Excel Developers's adjustments, as well.
It's difficult to understand what's the problem without seeing what are you copying, but you can try:
ActiveSheet.Cells(erow, 1).PasteSpecial Transpose:=True
set CopyFromRange = Range("H9:H21")
set CopyToRange = ActiveSheet.Cells(erow,1).Resize(1,13)
CopyToRange.Value = Application.Transpose(CopyFromRange.Value)