Hello I have a macro that copies files from specific folders to a single folder and I am wondering whether the code I have can be altered to pull multiple files from multiple specified folders within one loop, as now I have to create a new module for every single folder path/file.
I have the following code:
Sub SmplAPP()
Dim FSO As Object
Dim FrFldr As String
Dim ToFldr As String
Dim myVal1 As Variant
Dim myValn As String
myVal1 = InputBox("Please enter today's date in mm-dd format")
myValn = Replace(myVal1, "-", "\")
Range("I1").Value = myValn
FrFldr = "\\xxxf003\sample_data\SAMPLE_REPORTS\APPS\Reports\Regional\SAMPLE_APPLICATION\2017\" & myValn
ToFldr = "C:\Users\sample\Desktop\logs_to_upload"
If Right(FrFldr, 1) = "\" Then
FrFldr = Left(FrFldr, Len(FrFldr) - 1)
End If
If Right(ToFldr, 1) = "\" Then
ToFldr = Left(ToFldr, Len(ToFldr) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FrFldr) = False Then
MsgBox FrFldr & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FrFldr, Destination:=ToFldr
Call NextApp
End Sub
Any help would be greatly appreciated!
If you want copy from different folder, you may use collection. I have amended your subroutine:
Sub SmplAPP()
Dim FSO As Object
Dim collFrFldr As New Collection
Dim FrFldr As Variant
Dim ToFldr As String
Dim myVal1 As Variant
Dim myValn As String
myVal1 = InputBox("Please enter today's date in mm-dd format")
myValn = Replace(myVal1, "-", "\")
Range("I1").Value = myValn
collFrFldr.Add "\\xxxf003\sample_data\SAMPLE_REPORTS\APPS\Reports\Regional\SAMPLE_APPLICATION\2017\" & myValn
collFrFldr.Add "\\another folder"
collFrFldr.Add "\\yet another folder"
ToFldr = "c:\Users\u195567\test\"
If Right(ToFldr, 1) = "\" Then
ToFldr = Left(ToFldr, Len(ToFldr) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
For Each FrFldr In collFrFldr
If Right(FrFldr, 1) = "\" Then
FrFldr = Left(FrFldr, Len(FrFldr) - 1)
End If
If FSO.FolderExists(FrFldr) = False Then
MsgBox FrFldr & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FrFldr, Destination:=ToFldr
Next FrFldr
Call NextApp
End Sub
Related
I wanted to import or copy and paste data from an external file into the current Excel file using VBA. However, the external file contain a date of the previous month in it. For example, the external file name is Report_20221128. Every month, this external file date maybe different and not necessary be 28 of the month.
Here is what I have done so far.
Sub Report_Run()
Dim wb As Workbook
Dim file As Variant
Dim wbrow As Long, wbrow2 As Long, wbrow3 As Long
Day = Application.WorksheetFunction.EoMonth(Now(), "-1")
Set wb = Workbooks("Run Report " & VBA.Format(LDay, "ddmmyyyy") & ".xlsb")
wb.Worksheets("DD").Activate
wbrow3 = Cells(Rows.Count, "A").End(xlUp).Row
file = Dir(Environ("userprofile") & "\Desktop\Reports\Report_" & Format(Date, "yyyymmdd") & ".xlsx")
End Sub
However, the code unable to read on this line
file = Dir(Environ("userprofile") & "\Desktop\Reports\Report_" & Format(Date, "yyyymmdd") & ".xlsx")
Therefore, how should I set the code so that it can read this external file that contain any date of the previous month in it?
Import Worksheet From File Matching a Pattern
Sub ImportLastMonth()
' Constants
Const SRC_PATH_RIGHT As String = "\Desktop\Reports\"
Const SRC_FILE_LEFT As String = "Report_"
Const SRC_FILE_RIGHT As String = ".xlsx"
Const SRC_WORKSHEET_ID As Variant = "Sheet1" ' adjust! Name or Index
' Source Path
Dim sPathLeft As String: sPathLeft = Environ("USERPROFILE")
Dim sPath As String: sPath = sPathLeft & SRC_PATH_RIGHT
Dim sFolderName As String: sFolderName = Dir(sPath, vbDirectory)
If Len(sFolderName) = 0 Then
MsgBox "The path '" & sPath & "' was not found.", vbCritical
Exit Sub
End If
' Source File
Dim sPatternLeft As String: sPatternLeft = SRC_FILE_LEFT _
& Format(CDate(Application.EoMonth(Now, "-1")), "yyyymm")
Dim sPattern As String: sPattern = sPatternLeft & "*" & SRC_FILE_RIGHT
Dim sFileName As String: sFileName = Dir(sPath & sPattern)
If Len(sFileName) = 0 Then
MsgBox "No files matching the pattern '" & sPattern & "' in '" _
& sPath & "' found.", vbCritical
Exit Sub
End If
' Day
Dim DayStart As Long: DayStart = Len(sPatternLeft) + 1
Dim DayNumString As String, DayNum As Long, NewDayNum As Long
Do While Len(sFileName) > 0
DayNumString = Mid(sFileName, DayStart, 2)
If IsNumeric(DayNumString) Then
NewDayNum = CLng(DayNumString)
If NewDayNum > DayNum Then DayNum = NewDayNum
End If
Debug.Print sFileName, DayNumString, NewDayNum, DayNum
sFileName = Dir
Loop
If DayNum = 0 Then
MsgBox "No file found.", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
' Source
Dim sFilePath As String
sFilePath = sPath & sPatternLeft & Format(DayNum, "0#") & SRC_FILE_RIGHT
Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath, True, True)
Dim sws As Worksheet: Set sws = swb.Sheets(SRC_WORKSHEET_ID)
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
' Copy
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count) ' last
swb.Close SaveChanges:=False
Application.ScreenUpdating = True
' Inform.
MsgBox "Last month's final report imported.", vbInformation
End Sub
Using FileSystemObject and Like
Option Explicit
Sub Report_Run()
Dim wb As Workbook, TargetWB As Workbook
Dim DT As Date
Dim wbrow As Long, wbrow2 As Long, wbrow3 As Long
Dim FSO As Object, oFolder As Object, oFile As Object
Set FSO = CreateObject("scripting.filesystemobject")
' > This needs to be the folder you expect to contain your report
Set oFolder = FSO.getfolder("C:\Users\cameron\Documents\")
' > Date is already a VBA function, you have to use a different variable
DT = Application.WorksheetFunction.EoMonth(Date, "-1")
' > I have this set to "ThisWorkbook" as it's fewer things to worry about, but feel free to change this. _
What is LDay? \|/ you don't have this variable declared
Set wb = ThisWorkbook 'workbooks("Run Report " & VBA.Format(LDay, "ddmmyyyy") & ".xlsb")
' > Avoid using activate
wbrow3 = wb.Worksheets("DD").Cells(Rows.Count, "A").End(xlUp).Row
' > Check each file to see if they're from last month
For Each oFile In oFolder.Files
If oFile.Name Like "Report_" & Format(DT, "yyyymm") & "*" & ".xlsb" Then 'Report name with wildcard for day
Set TargetWB = Workbooks.Open(oFile.Path)
Exit For
End If
Next oFile
' > You now have the report book from last month open and saved to "TargetWB"
End Sub
I'm trying to open a folder where I don't know the full path.
For example, the parent folder dir is "D:\Documents" and the folder I want to open is called "22.111 - PROJECT_NAME", where I know the code, but don't know the name. I've tried with "*", but no luck.
Sub OpenFolder()
On Error GoTo Err_cmdExplore_Click
Dim Code As String
Code = Range("A1").Value
GoToFolder = "C:\Windows\explorer.exe D:\Documents\" & Code & "*"
Call Shell(GoToFolder, 1)
Exit_cmdExplore_Click:
Exit Sub
Err_cmdExplore_Click:
MsgBox ("Pasta não encontrada")
Resume Exit_cmdExplore_Click
End Sub
Found the answer on another forum (mrexcel.com), leaving it below for anyone that faces the same problem:
Public Sub Find_and_Open_Folder()
Dim Code As String
Dim targetFolder As String
Code = Range("A1").Value
targetFolder = Dir("D:\Documents\" & Code & "*", vbDirectory)
If targetFolder <> vbNullString Then
Shell "explorer.exe """ & "D:\Documents\" & targetFolder & """", vbNormalFocus
Else
MsgBox "Folder matching D:\Documents\" & Code & "* not found"
End If
End Sub
With the parent folder available and the knowledge that the subfolder starts with 22.111, you could loop through all subfolders in the parent folder, and list all the potential matches using InStr. Example of how you might do this:
Sub CodeSnippet()
Dim myFolderName As String
'GetFolders returns array
Dim folderNamesWithPattern As Variant
'searching for "22.111" at 1st pos in string of potential subfolder
folderNamesWithPattern = GetFolders("D:\Documents", "22.111", 1)
If UBound(folderNamesWithPattern) > 0 Then
'more than one folder that meets your pattern:
'decide what to do
Else
'only one entry in array, this is your folder or if "" then ( no such folder | parent folder does not exist )
myFolderName = folderNamesWithPattern(0)
End If
End Sub
Function GetFolders(strDirectory As String, pattern As String, position As Long) As Variant
Dim objFSO As Object
Dim objFolders As Object
Dim objFolder As Object
'create filesystem obj
Set objFSO = CreateObject("Scripting.FileSystemObject")
'create folder obj and access subfolders property
On Error GoTo errorHandler
Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
'dim array for matches
Dim arrFolderNames() As Variant
arrFolderNames = Array()
'loop through all folders
For Each objFolder In objFolders
'InStr() returns 0 if not found | index 1st char in string if found
If InStr(objFolder.Name, pattern) = 1 Then
'add match to array
ReDim Preserve arrFolderNames(UBound(arrFolderNames) + 1)
arrFolderNames(UBound(arrFolderNames)) = objFolder.Name
End If
Next objFolder
'assign array for return
GetFolders = arrFolderNames
errorHandler:
If objFolders Is Nothing Then
'parent folder does not exist
GetFolders = Array("")
ElseIf UBound(arrFolderNames) = -1 Then
'we never found a subfolder that starts with pattern
GetFolders = Array("")
End If
End Function
If you want to use RegEx, you might want to look at How do i use regex using instr in VBA.
Explore a Folder Using Workbook.FollowHyperlink
Workbook.FollowHyperlink method (MSDocs)
A Known Worksheet in the Workbook Containing This Code (ThisWorkbook)
Sub ExploreFolder()
Const iFolderPath As String = "D:\Documents\"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim Code As String: Code = CStr(ws.Range("A1").Value)
Dim dFolderPattern As String: dFolderPattern = iFolderPath & Code & "*"
Dim dFolder As String: dFolder = Dir(dFolderPattern, vbDirectory)
If Len(dFolder) > 0 Then
wb.FollowHyperlink iFolderPath & dFolder
Else
MsgBox "A folder matching the pattern '" & dFolderPattern _
& "' was not found.", vbCritical, "Explore Folder"
End If
End Sub
ActiveSheet (not recommended)
Sub ExploreFolderActiveSheet()
Const iFolderPath As String = "D:\Documents\"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Code As String: Code = CStr(ws.Range("A1").Value)
Dim dFolderPattern As String: dFolderPattern = iFolderPath & Code & "*"
Dim dFolder As String: dFolder = Dir(dFolderPattern, vbDirectory)
If Len(dFolder) > 0 Then
ws.Parent.FollowHyperlink iFolderPath & dFolder
Else
MsgBox "A folder matching the pattern '" & dFolderPattern _
& "' was not found.", vbCritical, "Explore Folder"
End If
End Sub
I need to do the following:
Allow the user to select any number of files, in any format, and copy them to a new folder.
Create the destination folder if it doesn't exist. In this case, the folder name should be given by the content of the C2 & C3 cells (Range("C2").Value & Range("C3").Text & "\").
Private Sub CommandButton4_Click()
Dim strDirname As String
Dim strDefpath As String
Dim strPathname As String
Dim strFilename As String
Dim FSO
Dim sFile As FileDialog
Dim sSFolder As String
Dim sDFolder As String
strDirname = Range("C2").Value & Range("C3").Text
MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename
Set sFile = Application.FileDialog(msoFileDialogOpen)
sDFolder = strDirname & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = New FileSystemObject
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If Not .Show Then Exit Sub
Set xFolder = FSO.GetFolder(.SelectedItems(1))
For Each xFile In xFolder.Files
On Error Resume Next
xRow = Application.Match(xFile.Name, Range("A:A"), 0)
On Error GoTo 0
Next
End With
End Sub
I know the error is here...
Set xFolder = FSO.GetFolder(.SelectedItems(1))
...because I'm asking it to get a file, not a folder.
It is not very clear to me what you are trying to do but, if you intend to select a folder, you have to use it
Application.FileDialog (msoFileDialogFolderPicker)
instead of
Application.FileDialog (msoFileDialogFilePicker)
Your posted code shows so little resemblance to what you Q asks for, I've disregarded it.
This code follows the description. You may need to alter certain details to fully match your needs
Sub Demo()
Dim FilePicker As FileDialog
Dim DefaultPath As String
Dim DestinationFolderName As String
Dim SelectedFile As Variant
Dim DestinationFolder As Folder
Dim FSO As FileSystemObject
DefaultPath = "C:\Data" ' <~~ update to suit, or get it from somewhere else
' Validate Default Path
If Right$(DefaultPath, 1) <> Application.PathSeparator Then
DefaultPath = DefaultPath & Application.PathSeparator
End If
If Not FSO.FolderExists(DefaultPath) Then Exit Sub
' Get Destination Folder, add trailing \ if required
DestinationFolderName = Range("C2").Value & Range("C3").Value
If Right$(DestinationFolderName, 1) <> Application.PathSeparator Then
DestinationFolderName = DestinationFolderName & Application.PathSeparator
End If
Set FSO = New FileSystemObject
' Get reference to Destination folder, create it if required
If FSO.FolderExists(DefaultPath & DestinationFolderName) Then
Set DestinationFolder = FSO.GetFolder(DefaultPath & DestinationFolderName)
Else
Set DestinationFolder = FSO.CreateFolder(DefaultPath & DestinationFolderName)
End If
' File Selection Dialog
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.AllowMultiSelect = True ' allow user to select multiple files
.InitialFileName = DefaultPath ' set initial folder for dialog
If .Show = False Then Exit Sub ' check if user cancels
For Each SelectedFile In .SelectedItems ' loop over selected files
If SelectedFile Like DefaultPath & "*" Then 'Optional: disallow browsing higher than default folder
FSO.CopyFile SelectedFile, DefaultPath & DestinationFolderName, True ' Copy file, overwrite is it exists
End If
Next
End With
End Sub
I have an Excel file with hundreds of Customer names and several article numbers.
I want to check if a folder with selected customer name exists and create a folder if it is missing.
Once the customer folder is found or created, check if there is a folder for each article number and if it is missing, create one.
I found code that seems to do all that and more posted by Scott Holtzman.
I have referenced Microsoft Scripting Runtime as the code requests.
Both of the "If not" statements are marked red and the pop-up window only says "Compile error".
I checked the syntax of "If not" statements and it seems to be correct.
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
' etc...
End Function
Take a look at the below example, it shows one of the possible approaches using recursive sub call:
Option Explicit
Sub TestArrays()
Dim aCustomers
Dim aArticles
Dim sCustomer
Dim sArticle
Dim sPath
sPath = "C:\Test"
aCustomers = Array("Customer01", "Customer02", "Customer03", "Customer04", "Customer05")
aArticles = Array("Article01", "Article02", "Article03", "Article04", "Article05")
For Each sCustomer In aCustomers
For Each sArticle In aArticles
SmartCreateFolder sPath & "\" & sCustomer & "\" & sArticle
Next
Next
End Sub
Sub TestFromSheet()
Dim aCustomers
Dim aArticles
Dim i
Dim j
Dim sPath
sPath = "C:\Test"
With ThisWorkbook.Sheets(1)
aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
aArticles = .Range("B1:B10").Value
End With
For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
For j = LBound(aArticles, 1) To UBound(aArticles, 1)
SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
Next
Next
End Sub
Sub SmartCreateFolder(sFolder)
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
If Not .FolderExists(sFolder) Then
SmartCreateFolder .GetParentFolderName(sFolder)
.CreateFolder sFolder
End If
End With
End Sub
Sub TestArrays() checks and creates folders for customers and articles from the hardcoded arrays, and Sub TestFromSheet() gets customers and articles from the first worksheet, as an example customers range from A1 up to the last element, so it should be more than one element there, and articles set to fixed range B1:B10, like shown below:
The StrComp Issue
You cannot use StrComp, its a reserved word, actually a string function. I lost about 15 minutes the other day on this issue.
VBA says: Returns a Variant (Integer) indicating the result of a string comparison.
If you want to shorthand a bunch of that code, use MKDIR to create each level of folder\subfolder with error pass-over.
Option Explicit
Sub main()
Dim pth As String
pth = "c:\test\abc\123\test_again\XYZ\01-20-2019"
'folder may or may not exist
makeFolder pth
'folder definitely exists
End Sub
Sub makeFolder(fldr As String)
Dim i As Long, arr As Variant
'folder may or may not exist
arr = Split(fldr, Chr(92))
fldr = arr(LBound(arr))
On Error Resume Next
For i = LBound(arr) + 1 To UBound(arr)
fldr = Join(Array(fldr, arr(i)), Chr(92))
MkDir fldr
Next i
On Error GoTo 0
'folder definitely exists
End Sub
To rename an existing file to a new location WITH creation of all subdirectories, you can use:
File_Name_OLD = File_Pad_OLD & "Test.txt"
File_Pad_NEW = "e:\temp\test1\test2\test3\"
File_Name_NEW = File_Pad_NEW & "Test.txt"
X = File_Pad_NEW
A = 1
Do Until A = 0
A = InStr(X, "\")
Y = Y & Left(X, A)
X = Mid(X, A + 1)
If Dir(Y, 16) = "" Then MkDir Y
Loop
Name File_Name_OLD As File_Name_NEW
This is creating the new path with subdirectories and renames the old file to the new one.
I've written a macro that downloads zip files containing CSVs from a website. The downloading and unzipping is going perfectly, however when I try to loop through the CSVs searching for the occurrence of a specific string, the macro simply quits after opening about a thousand. There is no error message, it simply stops working, leaving the last CSV it was working on open.
Here is my code:
Sub OpenSearch()
Dim ROW, j As Integer
Workbooks.Open Filename:=FileNameFolder & FileListCSV(i)
For j = 1 To 7
ROW = 3
Do Until IsEmpty(Cells(ROW, 6))
If Cells(ROW, 6) = WantedID(j, 1) Then
MsgBox "WE HAVE A MATCH!"
End If
ROW = ROW + 1
Loop
Next j
Workbooks(FileListCSV(i)).Close False
Kill FileNameFolder & FileListCSV(i)
End Sub
I did not include the main module that calls the this sub and downloads and unzips the files, because on its own, that works perfectly. It only stops working when the sub I copied here is being called.
The Filename comes from a public variable defined in the main module, WantedID contains the strings I need to find in the CSVs.
I've tried to put Application.Wait in the first line, but it did not solve the problem. Also how far the macro gets is completely random. It never stops after the same number of CSVs opened and closed.
UPDATE: Here is the code (parent sub) for the downloading and unzipping. I did not come up with this on my own, but copied it from an online source I cannot recall:
Public FileListCSV(1 To 288) As String
Public i As Integer
Public FileNameFolder As Variant
Public WantedID As Variant
Sub DownloadandUnpackFile()
Dim myURL As String
Dim YearNUM As Integer
Dim MonthNUM As Integer
Dim StarMonth, EndMonth As Integer
Dim DayNUM As Integer
Dim YearSTR As String
Dim MonthSTR As String
Dim DaySTR As String
Dim FixURL As String
Dim TargetFileName As String
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim DefPath As String
Dim strDate As String
Dim StrFile As String
Dim FileList(1 To 288) As String
Application.ScreenUpdating = False
FixURL = "http://www.nemweb.com.au/REPORTS/ARCHIVE/Dispatch_SCADA PUBLIC_DISPATCHSCADA_"
WantedID = Range(Cells(2, 1), Cells(8, 1))
YearNUM = 2016
StarMonth = 12
EndMonth = 12
For YearNUM = 2015 To 2016
For MonthNUM = StarMonth To EndMonth
For DayNUM = 1 To 31
YearSTR = CStr(YearNUM)
If MonthNUM < 10 Then
MonthSTR = "0" & CStr(MonthNUM)
Else:
MonthSTR = CStr(MonthNUM)
End If
If DayNUM < 10 Then
DaySTR = "0" & CStr(DayNUM)
Else:
DaySTR = CStr(DayNUM)
End If
myURL = FixURL & YearSTR & MonthSTR & DaySTR & ".zip"
Cells(1, 1) = myURL
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.Send
myURL = WinHttpReq.ResponseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
TargetFileName = "C:\Users\istvan.szabo\Documents \Basslink\AEMO RAW DATA\RAWRAW\" & YearSTR & MonthSTR & DaySTR & ".zip"
oStream.SaveToFile (TargetFileName)
oStream.Close
End If
'try unzippin'
Fname = TargetFileName
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = "C:\Users\istvan.szabo\Documents\Basslink\AEMO RAW DATA\RAWRAW\" & YearSTR & MonthSTR & DaySTR
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
i = 1
StrFile = Dir(FileNameFolder & "\")
Do While Len(StrFile) > 0
FileList(i) = FileNameFolder & "\" & StrFile
FileListCSV(i) = Left(StrFile, Len(StrFile) - 3) & "csv"
StrFile = Dir
i = i + 1
Loop
'unzip the unzipped
For i = 1 To 288
Fname = FileList(i)
If Fname = False Then
'Do nothing
Else:
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = "C:\Users\istvan.szabo\Documents\Basslink\AEMO RAW DATA\"
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Call OpenSearch
End If
Next i
End If
Next DayNUM
Next MonthNUM
StarMonth = 1
EndMonth = 5
Next YearNUM
Application.ScreenUpdating = True
End Sub
You could check the file without opening it. That would save you time and resources. Here is a quick draw of the code I would use:
Sub OpenSearch()
Dim ROW, j As Integer
Dim fileID
Dim buf As String
Dim tmp As Variant
Open FileNameFolder & FileListCSV(i) For Input As #1
For j = 1 To 7
ROW = 3
Do Until EOF(1)
Line Input #1, buf
'Remove double quotes
buf = Replace(buf, """", "")
'Split line to a array
tmp = Split(buf, ",")
'5 is the 6th column in excel tmp index starts with 0
fileID = tmp(5)
If fileID = WantedID(j, 1) Then
MsgBox "WE HAVE A MATCH!"
End If
ROW = ROW + 1
Loop
Next j
Close #1
Kill FileNameFolder & FileListCSV(i)
End Sub
EDIT: Also try to add a resource cleanup code, for example: Set WinHttpReq = Nothing, Set oStream = Nothing etc.
In line with other advice in the comments: -
You should close of resources when you are done with them using Set WinHttpReq = Nothing for example. This can avoid memory problems that are similar to the issue you are seeing.
It is also advisable to remove On Error Resume Next. This is hiding errors and you may well be missing results that you need. It would also allow for more information during errors.
I took your two code blocks and wrote them into one that I believe will be stable during running and make it to the end, Run this and let us know if it did resolve the issue. I did it this way as there was a lot of small changes that went towards what I suspect will be more stable and make it to the end.
Sub DownloadandUnpackFile()
Dim FSO As New FileSystemObject
Dim DteDate As Date
Dim Fl As File
Dim Fl_Root As File
Dim Fldr As Folder
Dim Fldr_Root As Folder
Dim LngCounter As Long
Dim LngCounter2 As Long
Dim oApp As Object
Dim oStream As Object
Dim oWinHttpReq As Object
Dim RngIDs As Range
Dim StrURL As String
Dim StrRootURL As String
Dim VntFile As Variant
Dim VntFolder As Variant
Dim VntRootFile As Variant
Dim VntRootFolder As Variant
Dim WkBk As Workbook
Dim WkSht As Worksheet
'This will speed up processing, but you might not see progress while it is working
Application.ScreenUpdating = False
'Set variables
StrRootURL = "http://www.nemweb.com.au/REPORTS/ARCHIVE/Dispatch_SCADA/PUBLIC_DISPATCHSCADA_"
'You should be a little more explicit here for clarity, refernce a worksheet
'E.g. StrID = ThisWorkbook.Worksheets("Sheet1").Range(Cells(2, 1), Cells(8, 1))
Set RngIDs = Range(Cells(2, 1), Cells(8, 1))
Set oWinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set oApp = CreateObject("Shell.Application")
'Loop from 21/Feb/2015 to today
For DteDate = CDate("21/Feb/2015") To Date
StrURL = StrRootURL & Format(DteDate, "YYYYMMDD") & ".zip"
Debug.Print StrURL
oWinHttpReq.Open "GET", StrURL, False
oWinHttpReq.Send
StrURL = oWinHttpReq.ResponseBody
If oWinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write oWinHttpReq.ResponseBody
VntRootFile = Environ("UserProfile") & "\Documents\Basslink\AEMO RAW DATA\RAWRAW\" & Format(DteDate, "YYYYMMDD") & ".zip"
oStream.SaveToFile VntRootFile
oStream.Close
Set oStream = Nothing
VntRootFolder = Environ("UserProfile") & "\Documents\Basslink\AEMO RAW DATA\RAWRAW\" & Format(DteDate, "YYYYMMDD") & "\"
FSO.CreateFolder VntRootFolder
oApp.Namespace(VntRootFolder).CopyHere oApp.Namespace(VntRootFile).Items
Set Fldr_Root = FSO.GetFolder(VntRootFolder)
'Unzip the zipped zips
For Each Fl_Root In Fldr_Root.Files
If Right(LCase(Fl_Root.Name), 4) = ".zip" Then
VntFolder = Fl_Root.ParentFolder & "\" & Left(Fl_Root.Name, Len(Fl_Root.Name) - 4) & "\"
FSO.CreateFolder VntFolder
VntFile = Fl_Root.Path
oApp.Namespace(VntFolder).CopyHere oApp.Namespace(VntFile).Items
Set Fldr = FSO.GetFolder(VntFolder)
For Each Fl In Fldr.Files
If Right(LCase(Fl.Name), 4) = ".csv" Then
Set WkBk = Application.Workbooks.Open(Fl.Path)
Set WkSht = WkBk.Worksheets(1)
For LngCounter = 1 To RngIDs.Rows.Count
LngCounter2 = 1
Do Until WkSht.Cells(LngCounter2, 6) = ""
If WkSht.Cells(LngCounter2, 6) = RngIDs.Cells(LngCounter, 1) Then
Debug.Print "FOUND: " & Fl.Name & ": " & WkSht.Cells(LngCounter2, 6).Address
End If
LngCounter2 = LngCounter2 + 1
Loop
Next
Set WkSht = Nothing
WkBk.Close 0
Set WkBk = Nothing
End If
DoEvents
Next
Set Fldr = Nothing
End If
Next
Fldr_Root.Delete True
Set Fldr_Root = Nothing
FSO.DeleteFile VntRootFile, True
End If
DoEvents
Next
Set oApp = Nothing
Set oWinHttpReq = Nothing
Set RngIDs = Nothing
Application.ScreenUpdating = True
End Sub
Changes I have made: -
I used early binding to FileSystemObject simply to make it easier
to write up. You will need the 'Windows Scripting Runtime' reference
added (Tools > References > tick 'Windows Scripting Runtime')
I iterated through dates as a single loop rather then three loops of
strings working as a date
I set IDs to be a range and note a variant
I opened references once, reuse them (i.e. oApp), and then close
them
I added DoEvents to give time back to the computer to run anything it
may need to, this maintains a health system.
I used Debug.Print to add information to the immediate window instead
of msgbox, but you should really list the finds out in a separate
worksheet, (debug.print has a size limit so you may end up only
seeing X number of results as others are truncated off.