Sub LoopThroughFolder()
Dim table As Range
Dim FSO
Dim month As String
Dim year As String
Dim FileName As String
Dim OldFileName As String
Dim MainPath As String
Dim ClientPath As String
Dim FullPath As String
Dim FileToOpen As Workbook
Dim Text As String
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("FileName")
month = ws.Range("E8")
year = ws.Range("F8")
OldFileName = ws.Range("R5")
MainPath = "C:\Document\documents\CPREIF_daily_test\"
ClientPath = MainPath & year & "\" & month & " - " & year & "\"
Set table = Range("B8", Range("B8").End(xlToRight).End(xlDown))
For Each Row In table.Rows
Text = Row.Cells(1, 1)
FileName = Row.Cells(1, 7)
Set FileToOpen = Workbooks.Open(ClientPath & OldFileName, UpdateLinks:=0)
Range("B4").ClearContents
Range("B4") = Text
Range("B4").NumberFormat = "dddd mmmm d" & ", " & "yyyy"
ActiveWorkbook.Close True, ClientPath & FileName
Next Row
MsgBox "Client Files Turned"
End Sub
Hey All. I wrote VBA to loop through each row of a table, renaming the workbook and changing the date within a cell, based off each row in a table. When I run the code within VBA editor, the code works. When I create a button and assign the macro to the button, I receive a runtime error. The code that breaks is:
ActiveWorkbook.Close True, ClientPath & FileName
Thanks!
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 am working on a code for my company that would take our production relief sheets and compile the data into one big document for compiling. I have a code that runs and does what I need it do; however, I have run into a problem. Our relief sheets are saved to our ShareDrive with the name of the current date (example: "4-27-2022"). Our site does not work on Saturdays or Sundays; therefore, we do not have relief sheets for Saturdays or Sundays. The code below works for importing data from a Monday-Friday, but it doesn't work if you want to look at dates that are separated by a weekend.
Is there a way to get excel to run my current code but skip the dates that do not have a file?
code:
Option Explicit
Sub ImportPolymerData()
'This sub imports the data from the polymer relief sheets based on the date range specified.
Dim StartDate As String, EndDate As String, SMonth As Integer, EMonth As Integer, d As String, dt As String
Dim StartY As String, SShortY As String, EndY As String, ShortEndY As String
Dim diff As Integer
Dim wbRS As Workbook 'Relief Sheet workbook
Dim wb As Workbook
Dim rng As Range
Dim r As Range
Dim dat As String
Dim i As Integer
Set wb = ThisWorkbook
Dim myPath As String
Dim myFile As String
Dim Dmonth As Integer
Application.ScreenUpdating = False
wb.Sheets("Inputs").Activate
StartDate = Range("B4").Value 'Pulls the start and end date out of cells B4 and B5
EndDate = Range("B5").Value
SMonth = Month(StartDate) 'Pulls the Month of the start and end date
EMonth = Month(EndDate)
StartY = Year(StartDate) 'Pulls the Year of the start and end date
EndY = Year(EndDate)
SShortY = Right(StartY, 2) 'Pulls the last two numbers of the year of the start and end date
ShortEndY = Right(EndY, 2)
'''Update FilePath after New Year'''
myPath = "\\cx.championx.com\AMER\US-Garyville\Groups\Champion X Operators\Polymer Relief Sheets\Polymer Relief Sheet Current\" & StartY
'Get date range difference
diff = DateDiff("d", StartDate, EndDate) 'Counts the number of days between the start and end date
'This will be the end of the loop for looping through the files
'MsgBox diff
'Clear Old Data
wb.Sheets("5B Polymer").Activate
wb.Sheets("5B Polymer").Range(Range("A2").End(xlToRight), Range("A2").End(xlDown)).Clear
On Error Resume Next 'tells excel to skip lines of code containing errors
'Loop through files
For i = 0 To diff 'From 0 to the # of days in the range of start date to end date
dat = wb.Sheets("Inputs").Range("B4").Value + i
Dmonth = Month(dat) 'Gets the month for whatever date you have going through the loop
'Format "dat" to find the Polymer Relief Sheet file
dt = Format(dat, "mm/dd/yyyy") 'Changes the date format to match the way dates are entered as relief sheet titles
d = Replace(dt, "/", "-")
'MsgBox d
'Opens the Relief sheet folder with the month of the dates
Select Case Dmonth
Case 1
myFile = myPath & "\01-JAN\" & d & ".xlsm"
Case 2
myFile = myPath & "\02-FEB\" & d & ".xlsm"
Case 3
myFile = myPath & "\03-MAR\" & d & ".xlsm"
Case 4
myFile = myPath & "\04-APR\" & d & ".xlsm"
Case 5
myFile = myPath & "\05-MAY\" & d & ".xlsm"
Case 6
myFile = myPath & "\06-JUN\" & d & ".xlsm"
Case 7
myFile = myPath & "\07-JUL\" & d & ".xlsm"
Case 8
myFile = myPath & "\08-AUG\" & d & ".xlsm"
Case 9
myFile = myPath & "\09-SEP\" & d & ".xlsm"
Case 10
myFile = myPath & "\10-OCT\" & d & ".xlsm"
Case 11
myFile = myPath & "\11-NOV\" & d & ".xlsm"
Case 12
myFile = myPath & "\12-DEC\" & d & ".xlsm"
End Select
'Open up
Set wbRS = Workbooks.Open(myFile)
'Unhides all hidden worksheets in the relief sheet workbook
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
'Get polymer data
wbRS.Sheets("5B Batches").Activate
Application.CutCopyMode = False
'Range(range("A2").end (xltoright), range("A2").end(xldown)).select
Range(Range("A2").End(xlToRight), Range("A2").End(xlDown)).Copy
With wb.Sheets("5B Polymer")
If .Range("A2") = "" Then
.Range("A2").PasteSpecial Paste:=xlPasteValues
Else
.Range("A2").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
End With
Application.CutCopyMode = False
'save and close
wbRS.Close False
Next i
wb.Sheets("5B Polymer").Activate
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Range("A2").Select
Sheets("Inputs").Range("I2").Value = Now
End Sub
Any help is greatly appreciated!
Make sure you don't use Select and Activate
see How to avoid using Select in Excel VBA
Instead make sure you have all Range, Cells, Columns and Rows objects fully referenced to a workbook and worksheet
Never use On Error Resume Next to hide all error messages. Your code cannot work properly then (if it works it works only by accident but not on purpose). Use this line only to handle an expected error and always turn on error reporting right after that expected error as I did when opening the file. Here we expect that opening a file can error because a file does not exist. So we handle that by testing for Nothing to see if the file was opened.
Option Explicit
Public Sub ImportPolymerData()
'This sub imports the data from the polymer relief sheets based on the date range specified.
' Application.ScreenUpdating = False 'either turn it on in the end or leave it out. If you reference everything properly and don't use Select you don't need that.
Dim wb As Workbook
Set wb = ThisWorkbook
Dim StartDate As String
StartDate = wb.Sheets("Inputs").Range("B4").Value 'Pulls the start and end date out of cells B4 and B5
Dim EndDate As String
EndDate = wb.Sheets("Inputs").Range("B5").Value
Dim SMonth As Long
SMonth = Month(StartDate) 'Pulls the Month of the start and end date
Dim EMonth As Long
EMonth = Month(EndDate)
Dim StartY As String
StartY = Year(StartDate) 'Pulls the Year of the start and end date
Dim EndY As String
EndY = Year(EndDate)
Dim SShortY As String
SShortY = Right(StartY, 2) 'Pulls the last two numbers of the year of the start and end date
Dim ShortEndY As String
ShortEndY = Right(EndY, 2)
'''Update FilePath after New Year'''
Dim myPath As String
myPath = "\\cx.championx.com\AMER\US-Garyville\Groups\Champion X Operators\Polymer Relief Sheets\Polymer Relief Sheet Current\" & StartY
'Get date range difference
Dim diff As Long
diff = DateDiff("d", StartDate, EndDate) 'Counts the number of days between the start and end date
'This will be the end of the loop for looping through the files
'Clear Old Data
With wb.Sheets("5B Polymer")
.Range(.Range("A2").End(xlToRight), .Range("A2").End(xlDown)).Clear
End With
'don't do that without proper error handling!!!
'On Error Resume Next 'tells excel to skip lines of code containing errors
'Loop through files
Dim i As Long
For i = 0 To diff 'From 0 to the # of days in the range of start date to end date
Dim dat As String
dat = wb.Worksheets("Inputs").Range("B4").Value + i
Dim Dmonth As Long
Dmonth = Month(dat) 'Gets the month for whatever date you have going through the loop
'Format "dat" to find the Polymer Relief Sheet file
Dim dt As String
dt = Format$(dat, "mm/dd/yyyy") 'Changes the date format to match the way dates are entered as relief sheet titles
Dim d As String
d = Replace$(dt, "/", "-")
'Opens the Relief sheet folder with the month of the dates
Dim MonthFolders As Variant
MonthFolders = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
'create file path and file name
Dim myFile As String
myFile = myPath & "\" & Format$(Dmonth, "00") & "-" & MonthFolders(Dmonth - 1) & "\" & d & ".xlsm"
'Try to open the file
Dim wbRS As Workbook 'Relief Sheet workbook
Set wbRS = Nothing
On Error Resume Next ' hide error just in next line!
Set wbRS = Workbooks.Open(myFile)
On Error GoTo 0 ' re-activate error reporting!!!
'run the following only if the file could be opened otherwise it does not exist
If Not wbRS Is Nothing Then
'Unhides all hidden worksheets in the relief sheet workbook
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
'Get polymer data
Application.CutCopyMode = False
With wbRS.Worksheets("5B Batches")
.Range(.Range("A2").End(xlToRight), .Range("A2").End(xlDown)).Copy
End With
With wb.Worksheets("5B Polymer")
If .Range("A2") = vbNullString Then
.Range("A2").PasteSpecial Paste:=xlPasteValues
Else
.Range("A2").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
wbRS.Worksheets("5B Batches").Columns("A:A").NumberFormat = "m/d/yyyy"
End With
Application.CutCopyMode = False
'!!! you don't save here!!! your comment is wrong or it needs to be SaveChanges:=True
'save and close
wbRS.Close SaveChanges:=False
End If
Next i
wb.Worksheets("5B Polymer").Columns("A:A").NumberFormat = "m/d/yyyy"
wb.Worksheets("Inputs").Range("I2").Value = Now
End Sub
I'm working on Excel for Mac, v16.53, with OS Catalina v10.15.7
I have an Excel workbook called SCRIPT with two sheets.
Sheet 1 has data entry areas and sheet 2 compiles those entries into a pseudo-table. The data in sheet 1 changes with every new person that is interviewed.
The data in sheet 2 is in columns A, B, H, I and J. It is non-contiguous and doesn't always have row 1 populated.
I can copy those five columns to a new csv file called Telesales-Leads-TODAY'S DATE.
The issue is when there already is a Telesales-Leads-TODAY'S DATE file.
The script is supposed to:
If Telesales-Leads-TODAY'S DATE file does not exist:
Start a new one.
Copy/paste the new SCRIPT data and save the Telesales-Leads-TODAY'S DATE file.
If a Telesales-Leads-TODAY'S DATE file does exist:
Copy the new data from the SCRIPT workbook to the first 100% empty column of the Telesales-Leads-TODAY'S DATE file.
Save the file with the same name (Telesales-Leads-TODAY'S DATE) in csv format.
It throws an error AFTER it copies the data from the SCRIPT workbook but BEFORE it has a chance to completely open the Telesales-Leads-TODAY'S DATE file.
I am using the MsgBox to debug.
Sub BackUpScriptData()
Dim strFileName As String
Dim strFileExists As String
Dim finalcolumn As Integer
Dim firstemptycolumn As Integer
Dim csvOpened As Workbook
Dim oneCell As Range
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim rngToSave As Range
Dim col As String
Dim ColumnNumber As Integer
Dim ColumnLetter As String
Dim colstart As String
Dim CellAddress As String
Dim TestChar As String
Dim NumberToLetter As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error GoTo err
strFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
strFileExists = Dir(strFileName)
If strFileExists = "" Then
MsgBox strFileName & " ~~~~~~~~doesn't exist"
Set myWB = ThisWorkbook
myCSVFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
Else
Set myWB = ThisWorkbook
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set csvOpened = Workbooks.Open(FileName:=strFileName)
MsgBox "csvOpened is " & csvOpened
With csvOpened
Set oneCell = Range("A1")
Do While WorksheetFunction.CountA(oneCell.EntireColumn)
Set oneCell = oneCell.Offset(0, 1)
Loop
MsgBox "oneCell.Column is " & oneCell.Column
End With
CellAddress = Cells(1, ColNum).Address
For i = 2 To Len(CellAddress)
TestChar = Mid(CellAddress, i, 1)
If TestChar = "$" Then Exit For
NumberToLetter = NumberToLetter & Mid(CellAddress, i, 1)
Next i
MsgBox "colstart is " & colstart
With csvOpened
.Sheets(1).Range(colstart & "1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
End If
err: MsgBox "failed to copy."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The code is essentially the same for creating a new workbook or updating an existing, the only difference being the column where the data is to be pasted. As this is a csv file then UsedRange is a simple way to determine the last clear column.
Sub BackUpScriptData2()
Const FOLDER = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/" & _
"User Content.localized/Startup.localized/Excel/"
Const PREFIX = "Telesales-Leads-"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, rngToSave As Range
Dim colNum As Long, myCSVFileName As String
myCSVFileName = PREFIX & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
' check if file exists
If Len(Dir(FOLDER & myCSVFileName)) = 0 Then
' not exists
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"does not exist, it will be created", vbInformation, FOLDER
Set wbCSV = Workbooks.Add()
colNum = 1
Else
' exists
Set wbCSV = Workbooks.Open(FOLDER & myCSVFileName)
With wbCSV.Sheets(1).UsedRange
colNum = .Column + .Columns.Count
End With
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"exists, it will extended from column " & colNum, vbInformation, FOLDER
End If
' copy and save
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
Set rngToSave = ws.Range("A1:B69,H1:J69")
rngToSave.Copy
With wbCSV
.Sheets(1).Cells(1, colNum).PasteSpecial xlPasteValues
.SaveAs Filename:=FOLDER & myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
MsgBox "File saved to " & myCSVFileName, vbInformation, FOLDER
End Sub
Soo.... having a problem saving the excel with as the name i want it to generate.. it keeps saving as "FALSE"... from what i can tell I have everything correct. Since the directory will be a variable I rather just have it save in the current folder.
Ultimately I want it as Week # m-d-yy Site.xlsm
e.i Week 36 9-5-20 41st HMU
Sub SaveWorkBook()
Dim wb As Workbook
Dim myFile As String
Dim dDate As Date
Dim sSite As String
dDate = Date 'Todays date
sSite = Range("Q10").Value 'Site Name
myFile = "Week " & WorksheetFunction.WeekNum(dDate, 2) & Format(dDate, "m-d-yy") & " " & sSite & ".xlsm"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName = myFile
End Sub
I want to open workbooks from particular folder, starting with Specific string listed down in Excel sheet.
Example :
I have an excel list -
123456
567890
654321
And the file names are starting with these numbers are like :
123456_example_stringxxxx.xlsx
567890 example stringxx.xlsx
654321-example stringxxxx.xlsx
stored at : C:\Users\Desktop\Testr\Excel_Files
Below is my code, but it opens just first file, I am trying to add loop but giving errors.
Sub Macro1()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim listFileName As String
Dim listName As String
Dim rowCount As Integer
rowCount = 1
listFileName = ActiveSheet.Range("A" & rowCount).Value
listName = listFileName & "*"
myPath = "C:\Users\Desktop\Test\Excel_Files"
myFile = Dir(myPath & listName & ".xlsx", vbNormal)
If Len(myFile) = 0 Then
'(Here I Want to add such kind of part's list to a text file)
Else
Workbooks.Open myPath & myFile
MsgBox "Successfull", vbInformation, "Opened Sucessfully"
End If
End Sub
Please sugest how can I create a loop or any better & simple code for it.
In addition ,
I want to search names from A1 to A10
Msg elert "Sucessfull" shouldnt be looped, it should be displayed at the end of process.
When any file is not found , the process shouldnt be stopped, it will list down the objects which are not found into a text file.
Regards,
Vivek Chotaliya
First you need to determine the last row used in column A, we do this using this line of code rowCount = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row, once that's done you can use a For Next loop to open all files that match column A listName.
inside the For Next I validate if the file was found, if it wasn't then it will call a small function to create a .txt file.
Give it a try to this...
Option Explicit
Public Sub Open_Workbooks()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim listFileName As String
Dim rowCount As Long
Dim i As Long
Dim bool As Boolean
bool = False
rowCount = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To rowCount
listFileName = ActiveSheet.Cells(i, 1)
myPath = "C:\Users\" & Environ("Username") & "\Desktop\Test\Excel_Files\"
myExtension = "*.xlsx"
myFile = Dir(myPath & listFileName & myExtension)
If Not Len(myFile) = 0 Then
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'do somenthing
'
'
'
'
'
'
'
wb.Close SaveChanges:=False
Else
Call Create_txt_Log(listFileName)
bool = True
End If
Next
If bool = False Then
MsgBox "Successfull", vbInformation, "Opened Sucessfully"
Else
MsgBox "Successfull but not all files where opened check text log file", vbInformation, "Opened Sucessfully"
End If
End Sub
Function...
Public Function Create_txt_Log(ByVal listFileName As String)
Dim Fileout As Object
Dim FSO As Object
Dim FolderPath As String
Dim myNotePadName As String
Dim myPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
myNotePadName = "Not_Found.txt"
myPath = "C:\Users\" & Environ("Username") & "\Desktop\Test\Files_Not_Found\"
FolderPath = myPath & myNotePadName
If FSO.FileExists(FolderPath) = False Then
Set Fileout = FSO.CreateTextFile(myPath & myNotePadName)
Fileout.Write listFileName
Fileout.Close
Else
Set Fileout = FSO.OpenTextFile(FolderPath, 8)
Fileout.Write vbCrLf & listFileName
Fileout.Close
End If
End Function