Sub LoopOtherRevenue()
Dim MyFile As String
Dim FilePath As String
FilePath = "C:\Users\jdubbaneh002\Desktop\Racetrac Other\"
MyFile = Dir(FilePath)
Do While Len(MyFile) > 0
If MyFile = "Book1.xlsm" Then
Exit Sub
End If
ActiveSheet.Range("A1:B14").Copy
Workbooks.Open (FilePath & MyFile)
ActiveWorkbook.Worksheets("A2) Monthly P&L (Source)").Activate
Range("B746:C759").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
Get a paste special error on line Range("B746:C759").PasteSpecial xlPasteValues
The values are being pasted into a combo box. that is where the error is coming from.
For me it seems like the file path is missing a "\"
FilePath = "C:\Users\jdubbaneh002\Desktop\Racetrac Other"
...
MyFile = Dir(FilePath)
...
If MyFile = "Book1.xlsm" Then
...
Workbooks.Open (FilePath & MyFile)
Correct:
Workbooks.Open (FilePath & "\" & MyFile)
Did you try debugging? Where does it throw the error?
I can see all sorts of issues because you're using ActiveWorkbook after opening the 2nd workbook. Is ActiveWorkbook still pointing at the one where the code is, or is it actually pointing at the one you just opened?
Create & set an as Workbook variable as assign the one the code is in to one, and the workbook you're opening to the other. That will eliminate all confusion.
Try this:
Sub LoopOtherRevenue()
Dim rgCopy as Range
Dim MyFile As String
Dim FilePath As String
Dim wb as Workbook
FilePath = "destination folder\"
MyFile = Dir(FilePath)
Set rgCopy = ActiveSheet.Range("A1:B14")
Do While Len(MyFile) > 0
If MyFile = "Book1.xlsm" Then
Exit Sub
End If
set wb Workbooks.Open(FilePath & "\" & MyFile)
rgCopy.Copy Destination:=wb.Worksheets("A2) Monthly P&L (Source)").Range("B746")
wb.Close
MyFile = Dir
Loop
End Sub
Related
Good afternoon,
I have tried searching different forums to no avail.
I have the below VBA code that will loop through all files in a folder and generate in a msge box the total number of rows of every file looped in that folder.
What I need your help on if possible is generate a summary report.
Ideally
The summary report will show File name and show how many rows with data in column H.
Sub LoopThroughFiles()
Dim folderPath As String
folderPath = ThisWorkbook.Path & "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
If Application.CountA(sh.Range("H:H")) > 0 Then
myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row
End If
Next
wb.Close False
Filename = Dir
Set wb = Nothing
Loop
MsgBox myCount
End Sub
You could try opening a "home" workbook where all values are stored. Basically, what you'll need to do is open a new workbook, and during your loop through each of the files, you'll paste the file path and the row count in the new workbook. Hopefully this will help, or at least give you an idea of how to do what you're trying to do. `
Sub LoopThroughFiles()
Dim folderPath As String
Dim summarySheet as Workbook
set summarySheet = workbook.add
folderPath = ThisWorkbook.Path & "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
If Application.CountA(sh.Range("H:H")) > 0 Then
myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row
End If
Next
wb.Close False
summarySheet.activate
Range("A:A").insert Shift:=xlDown
Cells(1,1) = Filename
Cells(1,2) = myCount
Filename = Dir
Set wb = Nothing
Loop
MsgBox myCount
End Sub`
I am trying to prepare a code that opens all files in a folder, checks the name of the sheet in the opened file and, depending on the name of that sheet, re-saves it in to a new folder. However, when I'm trying to add the IF statement to check that the sheet name exists, it's telling me that this Method does not exist. Is anybody able to advise a more appropriate method please?
Dim MyFile As String
MyPath = "Q:\Folder Name1\Folder Name2\Folder Name3\Folder Name4\"
MyFile = Dir(MyPath)
Do While MyFile <> ""
If MyFile Like "*.xlsx" Then
Workbooks.Open MyPath & MyFile
Dim ws1 As Worksheet
Set ws1 = Sheets("Adult_Return")
If ws1.Exists Then
ChDir "Q:\Folder Name1\Folder Name2\Folder Name3\Folder Name4\Return"
ActiveWorkbook.SaveAs Filename:=MyFile & ".xlsx"
Else
ChDir "Q:\Folder Name1\Folder Name2\Folder Name3\Folder Name4\Single"
ActiveWorkbook.SaveAs Filename:=MyFile & ".xlsx"
Thanks.
Create a function:
Function SheetExists(wb As Workbook, sheetName As String)
Dim ws As Worksheet
SheetExists = False
For Each ws In wb.Sheets
If UCase(ws.Name) = UCase(sheetName) Then
SheetExists = True
Exit Function
End If
Next ws
End Function
Call it like this:
Dim wb As Workbook
Set wb = Workbooks.Open(MyPath & MyFile)
If SheetExists(wb, "Adult_Return") Then
...
Btw: You don't have to do the chdir, just put the path in the SaveAs:
wb.SaveAs "Q:\Folder Name1\Folder Name2\Folder Name3\Folder Name4\Single\" & MyFile & ".xlsx
And: Do not forget to close the workbook!
I have a folder with nearly 1000 .csv files. Each of these files contains 2 columns, and I would like to copy only one of these columns and transpose it onto a new workbook. The new workbook will contain all the data from each of these files. The following code is what I have generated:
Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
folderPath = "J:etc. etc. etc." 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.csv")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWorkbook.Close True
Windows("Compiled.xlsm").Activate
Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
For whatever reason the code does not work and a box pops-up saying "Code execution has been interrupted." Once I hit "Debug" the following line is highlighted:
wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
I am not experienced with VBA at all and I am having trouble troubleshooting this issue. Any idea on what this means and what I can do?
The highlighted line is referring to a range on the workbook that is running the macro as opposed to the range within the workbook you have opened. Try replacing with this:
wb.Range(wb.Range("B1"), wb.Range("B1").End(xlDown)).Select
However I would suggest you avoid using the Select function altogether as it tends to slow down code. I've trimmed the loop a bit to avoid using Select and Activate:
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Range(wb.Cells(1,"B"), wb.Cells(Rows.Count,"B").End(xlUp)).Copy
Workbooks("Compiled.xlsm").Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
wb.Close True
Filename = Dir
Loop
Once you open file file, the active workbook is the book just opened and the active sheet is also established.
Your code fails primarily because of the wb.. (In general you would use a sheet reference instead), but in this case, replace:
wb.Range(Range("B1"), Range("B1").End(xlDown)).Select
with:
Range("B1").End(xlDown)).Select
(You also do not need Select to accomplish a copy/paste)
try with below
Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
folderPath = "c:\work\test\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Range("B1:B" & Range("B" & Rows.count).End(xlUp).Row).Copy
Workbooks("Compiled").Worksheets("Sheet1").Range("A" & Range("A" & Rows.count).End(xlUp).Row + 1).PasteSpecial Transpose:=True
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
wb.Range(...) will never work since wb is a Workbook object. You need a Worksheet object. Try:
Dim ws As Worksheet
Set ws = wb.Activesheet
ws.Range(ws.Range("B1"), ws.Range("B1").End(xlDown)).Select
In a quest to further never do anythign manual ever again
I made an it.xlsm that you have to put together in a folder with a specific file that has to be processed.
This it.xslm has three modules:
Masterfile
- renames the categories in C
-makes a worksheet per category in C
-saves those worksheets as .xslx. This results in 8 new files in a /Departement folder
Littlefiles
-renames the categories in E
-makes tabs for each category
-cleans up empty columns.
placeholder
Opens the .xls with the data
Applies Masterfile
Opens all the files created by masterfiles
makes tabs and cleans up empty columns.
Placeholder's code:
Sub OpenBigFile()
Dim wb As Workbook
Dim ws As Worksheet
Dim Lastrow As Long
'open main file, apply masterfile moduke
Set wb = Workbooks.Open(ThisWorkbook.path & "\Depositformulier (Reacties).xlsx")
Call masterfile.total
wb.Close SaveChanges:=True
End Sub
This works fine.
Sub OpenAllFiles()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
myPath = ThisWorkbook.path & "\" & "Departement" & "\"
myFile = Dir(myPath & "*.xlsx")
Do While Len(Filename) > 0
DoEvents
Set wb = Workbooks.Open(myPath & myFile, True, True)
Call LittleFiles.total
wb.Close False
myFile = Dir
Loop
End Sub
Here I find myself in problems. I tried to rewrite it many times, using many examples, but always it seems to be stuck at Set wb = Workbooks.Open(Filename:=myPath & myFile)
What am I doing wrong?
Do you need my Littlefiles code?
Also, in general, is it correct that 'ThisWorkbook' will always refer to the this.xlm,even if in the mean time another workbook is active (this being ActiveWorkbook)?
Thanks a bunch
Here's my attempt, i think this way it'll be harder to go wrong as you will have the full path of the file already stored:
Sub OpenAllFiles()
'create an array
Dim myFiles As Variant
ReDim myFiles(500)
myPath = ThisWorkbook.Path
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
'search for at least 5 files in the folder specified above, add the entire path to the array
While myCount < 5
If Dir(myPath & "*.xlsm") <> "" Then
potentialFileToLoad = Dir(myPath & "*.xlsm")
While potentialFileToLoad <> ""
myFiles(myCount) = myPath & potentialFileToLoad
myCount = myCount + 1
potentialFileToLoad = Dir
Wend
End If
Wend
'change size of array to ammount of files found
ReDim Preserve myFiles(myCount - 1)
For Each ii In myFiles
'(Insert Open, Run code, close code here)
Workbooks.Open (ii), True, True
Call LittleFiles.Total
ActiveWorkbook.Close
Next ii
End Sub
try something similar to this
path = "path2folder" & "\" 'this is fairly important and probably why your code breaks?_
you cant add the backslash like you do above
Filename = Dir(path & "*.xl??")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
'add your code
wbk.Close False
Filename = Dir
Loop
I have few files in a directory or a folder and I want to copy a range (values with format to the current sheet). I have VBA code and I think it is not in order or something is missing in the code. Please help me to fix the issue.
(I have defined named range in each files in the directory. Is it is possible to copy using the named range?)
Copy from directory files given path & from sheet2 & paste it to file "workbook.xlsm" Sheet "sheet1"
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\test"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "workbook.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Sheets("Sheet2").Select
Range("A1:N24").Copy
Workbooks.Open ("Filepath & workbook.xlsm")
If Sheets("Sheet1").Range("A1") = vbNullString Then
Sheets("Sheet1").Range ("A1:N24")
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteValues
Else
Selection.Copy Sheets("sheet1").Cells(A1, Columns.Count).End(xlToLeft).Offset(0, 1)
End If
MyFile = Dir
Loop
End Sub
One question remains:
(I have defined named range in each files in the directory. Is it is possible to copy using the named range?)
It's certainly possible. Thus assuming the Defined Name range is "DATA".
Just replace this line:
sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy
with this:
sourceWbk.Sheets("Sheet2").Range("DATA").Copy
Actually, OP mentioned that this Names are generated by another procedure with the address "A1:N24". So in the case that the address is changed then there will be a need to update every other procedure that refers to it, instead by using the Defined Name don't have to worry about it as it will be taking care by design. That why it’s a good practice to use Defined Names.
I'd use this method:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim FilePath As String
Dim colFiles As Collection
Dim vFile As Variant
Dim wrkbkSource As Workbook
Dim wrkbkTarget As Workbook
Dim rngTarget As Range
FilePath = "C:\test\"
MyFile = "workbook.xlsm"
Set colFiles = New Collection
EnumerateFiles FilePath, "*.xlsm", colFiles
Set wrkbkTarget = Workbooks.Open(FilePath & MyFile)
For Each vFile In colFiles
If vFile <> FilePath & MyFile Then
Set wrkbkSource = Workbooks.Open(vFile, False)
wrkbkSource.Worksheets(1).Range("A1:N24").Copy
Set rngTarget = wrkbkTarget.Worksheets("Sheet1").Cells(1, wrkbkTarget.Worksheets("Sheet1").Columns.Count).End(xlToLeft)
rngTarget.PasteSpecial xlPasteFormats
rngTarget.PasteSpecial xlPasteValues
wrkbkSource.Close False
End If
Next vFile
End Sub
This procedure is needed to get all the files in the folder:
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
Okay see if it works for you, had to add quite a bit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Dim targetWbk As Workbook
Dim sourceWbk As Workbook
Filepath = "C:\test"
MyFile = Dir(Filepath)
Workbooks.Open (Filepath & "\workbook.xlsm")
Set sourceWbk = ActiveWorkbook
Do While Len(MyFile) > 0
If Not MyFile = "workbook.xlsm" And MyFile = "*.xls*" Then
Workbooks.Open (Filepath & MyFile)
Set sourceWbk = ActiveWorkbook
sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy
If targetWbk.Sheets("Sheet1").Range("A1") = vbNullString Then
targetWbk.Sheets("Sheet1").Range("A1:N24").PasteSpecial xlPasteFormulas, xlPasteValues
Else
targetWbk.Sheets("sheet1").Cells(A1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteFormulas, xlPasteValues
End If
MyFile = Dir
End If
Loop
End Sub