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.
Related
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.
The code listed below is working for me to combine multiple workbook sheet1 (specific cell range) to the master sheet . But i'm facing one issue that is the paste special option is not working
For eg: My cells contains background color indication like amber, green and font color in each cells are different .I'm getting the output as plain text instead of rich text. If I try to modify the code with Pastespecial it's not working .
Can someone help me to fix this ?
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "Paste your path
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
End If
Workbooks.Open (Filepath & MyFile)
Range("A2:G2").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, 7))
MyFile = Dir
Loop
End Sub
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
I'm trying to use vba in excel to auto loop a set of files to paste their data into a master spreadsheet. I think I have the code right, almost-- but there is one big issue. The files loop and data copies, but every time another set of data is pasted, it overwrites the previously pasted data. I need the data from all the looped files to populate onto the master one after another, not one replacing the other. I've pasted the code I'm using below. Thanks in advance for your help!
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "V:\Purchasing\Grocery\Promos-DF and Grocery Assistants\HHL\HHL 2016\10-October 2016 HHL\Initial\New Folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zOctober Master.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Rows("21:100").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).Row
ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 1))
MyFile = Dir
Loop
End Sub
Use the cell you want as the top-left corner of your destination.
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).Row
Sheet1.Paste Destination:=Sheet1.Cells(erow, 1)
Either use the Worksheet .Name property or the Worksheet .CodeName property. Mixing and matching can only lead to trouble if they become 'unsynced'. In other words, if you ask for the next row to paste into from the worksheet codename Sheet1, then use the worksheet codename Sheet1 to identify the destination of your paste. There is nothing in your code that guarantees that the ActiveSheet property is the worksheet identified by Sheet1 codename, nor is there any guarantee that either is the worksheet with a name tab that says Sheet1.
I believe the issue you are encountering is caused by the End(xlUp) call. The way you have it written (starting from the last occupied row), it will always go back to the first cell, hence the overwritting. If you remove this call (keeping the 2 row offset), your sub should function as desired.
In general, it is best to avoid using End() entirely because its function varies depending upon the cells it encounters (for example, if you call End(xlToLeft) while in a merged cell, it will travel to the first cell in the merged range regardless of whether or not the cells before that are occupied and contiguous)
There is no need to Select or Active Ranges. It is best to work with the Range directly.
Open External WorkBook and then Copy a Range to the Original Workbook.
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim xlMyWorkBook As Workbook
Dim Filepath As String
Filepath = "V:\Purchasing\Grocery\Promos-DF and Grocery Assistants\HHL\HHL 2016\10-October 2016 HHL\Initial\New Folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zOctober Master.xlsm" Then
Exit Sub
End If
Set xlMyWorkBook = Workbooks.Open(Filepath & MyFile)
xlMyWorkBook.ActiveSheet.Rows("21:100").Copy Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
xlMyWorkBook.Close
MyFile = Dir
Loop
End Sub
Updated:
Changed
xlMyWorkBook.Rows
To
xlMyWorkBook.ActiveSheet.Rows
Use this for Debugging
Sub LoopThroughDirectory()
Const bDebugging As Boolean = True
Dim MyFile As String
Dim erow
Dim wbSource As Workbook, wbTarget As Range
Dim Filepath As String
Dim lastRow As Long
Filepath = "V:\Purchasing\Grocery\Promos-DF and Grocery Assistants\HHL\HHL 2016\10-October 2016 HHL\Initial\New Folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zOctober Master.xlsm" Then Exit Sub
lastRow = Sheet1.Cells(rows.Count, 1).End(xlUp).Row + 2
Set wbTarget = Sheet1.Cells(lastRow, 1)
Set wbSource = Application.Workbooks.Open(Filepath & MyFile)
If bDebugging Then
wbSource.ActiveSheet.rows("21:100").Select
MsgBox "This is the Source Range", vbInformation
Sheet1.Activate
MsgBox "This is the Destination Range", vbInformation
Else
wbSource.ActiveSheet.rows("21:100").Copy wbTarget
End If
wbSource.Close False
MyFile = Dir
Loop
End Sub
since your quite "fixed" rangetocopy address (always Rows("21:100")) if you could also fix the maximum columns number (say 100) you can avoid the burden and hassle of opening/closing workbooks and just go like follows:
Option Explicit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim Filepath As String
Dim iFile As Long
Filepath = "V:\Purchasing\Grocery\Promos-DF and Grocery Assistants\HHL\HHL 2016\10-October 2016 HHL\Initial\New Folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile <> "zOctober Master.xlsm" Then
iFile = iFile + 1
With ActiveSheet.Range("A1:A80").Resize(,100).Offset((iFile - 1) * 80)
.Formula = "='" & Filepath & "[" & MyFile & "]Sheet1'!A21"
.value = .value
End With
End If
MyFile = Dir
Loop
End Sub
Actually it's possible to act similarly even if you can't assume a "fixed" maximum columns number from the source sheets.
But for starters let's begin like above
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)