The code I have loops through a folder that has 100+ files (with more files being added daily) and copies files, data, etc. Every file that I loop through ends up in the VBA Project Explorer as you can see from the picture. This is really slowing down the run time of my code. Is there any way I can prevent each workbook from being added to the Project Explorer? Also, I haven't run my code with the optimize subroutines that I call to because I added those after running my original code (and now the editor is basically frozen). I attached my code as well as the picture of my issue below!
Sub TransferSAPCLData_Click()
'Code Optimization
Call OptimizeCode_Begin
'Declaring and Setting Variables
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim MyDir As String
Dim fil As Scripting.file
Dim FolderSource As Scripting.Folder
Dim FolderPathDest As String, wbDest As Workbook, wsDest As Worksheet
Dim wbSource As Workbook, wsSource As Worksheet
Dim lrDest As Long, fileDest As String, lrSource As Long
Dim CurrentFile As String
Dim fileSource As String
MyDir = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\SAPCL Spreadsheets\SAPCL Raw Data Files"
'Defining destination characteristics
FolderPathDest = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\Master SAPCL Folder"
fileDest = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\Master SAPCL Folder\Function Master File.xlsm"
'Workbooks.Open Filename:=fileDest
Set wbDest = ActiveWorkbook ' Workbooks("MASTER.xlsx")
Set wsDest = wbDest.Worksheets("Sheet1")
'Looping through files
Set FolderSource = fso.GetFolder(MyDir)
For Each fil In FolderSource.Files
Debug.Print fil.Name
CurrentFile = fil.Name
If Not fso.FileExists(FolderPathDest & "\" & fil.Name) Then
fso.CopyFile _
Source:=MyDir & "\" & fil.Name _
, Destination:=FolderPathDest & "\" & fil.Name
fileSource = MyDir & "\" & fil.Name
Workbooks.Open Filename:=fileSource '
ActiveWindow.Visible = False
Set wbSource = Workbooks(CurrentFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
wsSource.Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next fil
'Optimize Code
Call OptimizeCode_End
End Sub
Related
Previously I was having issues with the lrSource variable not referencing the correct worksheet, but I added code to fix this issue. Before I corrected the issue, the code would paste some data into "MASTER.xlsx" but not the correct portions due to the lrSource variable not getting the correct last row. Now, I can get the correct last row and I don't receive any errors, but no data is copied to the file destination ("MASTER.xlsx")...Any suggestions?
Sub btnUpdateSAPData_Click()
'Declaring and Setting Variables
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim MyDir As String
Dim fil As Scripting.file
Dim FolderSource As Scripting.Folder
Dim FolderPathDest As String, wbDest As Workbook, wsDest As Worksheet
Dim wbSource As Workbook, wsSource As Worksheet
Dim lrDest As Long, fileDest As String, lrSource As Long
Dim CurrentFile As String
Dim fileSource As String
MyDir = "C:\Users\quirk\Desktop\Cory Project\Wave 1A Content\SAPCL Spreadsheets\July 2018"
'Defining destination characteristics
FolderPathDest = "C:\Users\quirk\Desktop\Cory Project\VBA Code\Master FOlder"
fileDest = "C:\Users\quirk\Desktop\Cory Project\VBA Code\Master FOlder\MASTER.xlsx"
'Workbooks.Open Filename:=fileDest
Set wbDest = ActiveWorkbook ' Workbooks("MASTER.xlsx")
Set wsDest = wbDest.Worksheets("Sheet1")
'Looping through files
Set FolderSource = fso.GetFolder(MyDir)
For Each fil In FolderSource.Files
Debug.Print fil.Name
CurrentFile = fil.Name
If Not fso.FileExists(FolderPathDest & "\" & fil.Name) Then
fso.CopyFile _
Source:=MyDir & "\" & fil.Name _
, Destination:=FolderPathDest & "\" & fil.Name
fileSource = MyDir & "\" & fil.Name
Workbooks.Open Filename:=fileSource '
ActiveWindow.Visible = False
Set wbSource = Workbooks(CurrentFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next fil
End Sub
I'm not good with VBA at all but I was curious to know if there is a way to count the amount of worksheets in a workbook that's looped for all the files in a folder.
For example, A1 list the file names and B1 shows the count of sheets.
A1 B1
book1 5
book2 6
currently have this code set up and need to adjust it
Sub ListAllFile()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = Worksheets.Add
Set objFolder = objFSO.GetFolder("W:\101g-19 (4.20.18) - Copy\")
ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
For Each objFile In objFolder.Files
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
'ADD A WORKSHEET AND PASTE "=SHEETS()" in A1 the copy value of a1 in to list
'close files with out saving
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Take a look at the below - note that you should run this from inside of a blank worksheet
Set CurrentWB = ActiveWorkbook
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim J As Long
Dim N As Long
Dim lc As Long
Dim lr As Long
'UPDATE FOLDER PATH OF WHERE XLS FILES ARE LOCATED
folderPath = "C:\Users\username\Desktop\test\" 'change to suit
J = 2
' Column Headers
CurrentWB.Sheets(1).Range("A1").Value = "Filename"
CurrentWB.Sheets(1).Range("B1").Value = "# of Sheets"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'YOU CAN CHANGE TO BE ANY FILE TYPE BUT CURRENTLY SET TO .XLSX
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set TempWB = Workbooks.Open(folderPath & Filename)
' Counts Per Worksheet
N = ActiveWorkbook.Worksheets.Count
CurrentWB.Sheets(1).Range("A" & J).Formula = Filename
CurrentWB.Sheets(1).Range("B" & J).Formula = N
' Close Temporary Workbook
TempWB.Close False
J = J + 1
Filename = Dir
Loop
In your for loop, open the file (assuming they are all excel here) and get the count of worksheets.
Something like:
For Each objFile In objFolder.Files
writeCell = ws.Cells(ws.UsedRange.Rows.Count + 1, 1)
writeCell.Value = objFile.Name
'ADD A WORKSHEET AND PASTE "=SHEETS()" in A1 the copy value of a1 in to list
'close files with out saving
Set wb = Workbooks.Open(objFile.Name)
writeCell.Offset(,1).value = wb.Worksheets.Count()
wb.Close(false)
Next
Sub ListallFiles()
Dim sFileName As String
Dim sFolderPath As String: sFolderPath = "C:\Temp\" ' Change folder path. Ensure that folder path ends with "\"
Dim oWB As Workbook
Dim oWS As Worksheet
' Get the first excel file name from specified folder
sFileName = Dir(sFolderPath & "*.xls*")
' Add a worksheet
Set oWS = ThisWorkbook.Worksheets.Add
With oWS
' Set folder name in the new sheet
.Range("A1").Value = "The file found in " & sFolderPath & " are:"
' Loop through all excel files in the specified folder
Do While Len(Trim(sFileName)) > 0
' Open workbook
Set oWB = Workbooks.Open(sFolderPath & sFileName)
' Set workbook details in the file
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Value = sFileName
.Range("B" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Value = oWB.Worksheets.Count
' Close workbook
oWB.Close False
' Clear workbook object
Set oWB = Nothing
' Get next excel file
sFileName = Dir()
Loop
End With
End Sub
Above UDF should open all files in the specified folder and give you the number of worksheets in each workbook on a new worksheet
I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub
Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)
This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I want to move files to another folder from an Excel file (listfiles.xlsx) which contains paths of files in column A. The code below didn't work for me, can you help me please?
Sub movefile1()
Dim fso As FileSystemObject
Dim i As Long
Dim worksh As Worksheet
Dim workboo As Workbook
Set fso = CreateObject("scripting.filesystemobject")
Destination = "C:\Users\Desktop\Folder"
Set workboo = Workbooks.Open("C:\Users\TOSHIBA\Desktop\list_files.xlsx")
Set worksh = Worksheets("Listing")
numRows = worksh.Range("A" & Rows.Count).End(xlUp).Row
workboo.Windows(1).Visible = False
For i = 2 To numRows
Filepath = worksh.Range("A" & i).Value
fso.CopyFile Filepath, Destination
Next
End Sub
I changed the code but the fso.CopyFile Filepath, Destination does not work. They say permission refused
Place the line numRows = .Range("A" & .Rows.Count).End(xlUp).Row before the loop, otherwise the loop won't be executed at all
I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore