How to import external file with date as name - excel

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

Related

How to move files using partial file name?

I learnt how to copy multiple files from a single folder to multiple folders depending on file name in Excel sheet.
Sub MoveSelectedfiles()
Dim FSO As Scripting.FileSystemObject
Dim fl As Scripting.File
Dim sourcefldr As Scripting.Folder
Dim destinationFldr As Scripting.Folder
Dim index As Integer
Dim lastrow As Integer
Set FSO = New FileSystemObject
Set sourcefldr = FSO.GetFolder("E:\Testing\Source")
Set destinationFldr = FSO.GetFolder("E:\Testing\Destination")
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For index = 2 To 10
If (FSO.FileExists(sourcefldr.Path & "\" & Sheet1.Range("A" & index).Value)) Then
FSO.MoveFile sourcefldr.Path & "\" & Sheet1.Range("A" & index).Value, destinationFldr.Path & "\"
End If
Next index
End Sub
I have to define the exact file name. I would like to write even half/incomplete file name.
E.g. If a file name is "Excel training makes easy" and in the Excel sheet I write "Excel training".
Move Files From a List of Partial File Names
You can use the Dir function with wild characters (* and ?) to test if a file exists, e.g.:
Begins with
sFileName = Dir(sFolderPath & sPartialFileName & "*")
Contains
sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
Then you can continue with:
if len(sFileName) > 0 Then ' source file found
Partial File Names
Sub MoveFilesFromListPartial()
Const sPath As String = "E:\Testing\Source"
Const dPath As String = "E:\Testing\Destination"
Const fRow As Long = 2
Const Col As String = "A"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet1
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
For r = fRow To lRow
sPartialFileName = CStr(ws.Cells(r, Col).Value)
If Len(sPartialFileName) > 0 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*")
' or instead, 'Contains' sPartialFileName
'sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
If Len(sFileName) > 0 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.MoveFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
MsgBox "Stats" & vbLf _
& "Source files moved: " & sYesCount & vbLf _
& "Source files not found: " & sNoCount & vbLf _
& "Source files existed in destination: " & dYesCount & vbLf _
& "Number of blank cells: " & BlanksCount & vbLf _
& "Number of cells processed: " & lRow - fRow + 1, _
vbInformation
End Sub
Full File Names
Sub MoveFilesFromList()
Const sPath As String = "E:\Testing\Source"
Const dPath As String = "E:\Testing\Destination"
Const fRow As Long = 2
Const Col As String = "A"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet1
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file doesn't exist
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
For r = fRow To lRow
sFileName = CStr(ws.Cells(r, Col).Value)
If Len(sFileName) > 0 Then ' the cell is not blank
sFilePath = sFolderPath & sFileName
If fso.FileExists(sFilePath) Then ' the source file exists
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.MoveFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination folder
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
MsgBox "Stats" & vbLf _
& "Source files moved: " & sYesCount & vbLf _
& "Source files don't exist: " & sNoCount & vbLf _
& "Source files existed in destination: " & dYesCount & vbLf _
& "Number of blank cells: " & BlanksCount & vbLf _
& "Number of cells processed: " & lRow - fRow + 1, _
vbInformation
End Sub

Copy data from a workbook to an existing workbook

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

Efficient way to copy images and data from multiple source workbook to a single workbook

I have the following code to copy images from one workbook to another. The code opens the source workbook/sheet, copies the image then closes the workbook. This process repeats multiple times. Is there a more efficient way to do this? maybe bypassing the clipboard?
I only need to copy 1 image(named "Picture 4") and 2-3 cell values per source workbook/sheet. I have 7-8 source workbook.
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
So the fast solution is here:
Turn off Screen Updating and then turn it on again afterwards, I implemented some time measurement in my code to visualize this:
Option Explicit
Sub copy_images_original()
Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Sheets(1)
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
srcWB.Close
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")
srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
srcWB.Close
End Sub
Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim StartTime As Double
Dim SecondsElapsed As Double
'Remember time when macro starts
StartTime = Timer
'*****************************
Call turn_app_off
Call copy_images_original
Call turn_app_on
'*****************************
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Sub turn_app_off()
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
End Sub
Sub turn_app_on()
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
What has now improved?
Your srcWBs will now be closed, your original source code didnt do that.
In my scenario here, the execution time improved from 2 Secs to 1,4 Secs.
So your Code runs 25% faster without much effort.
Hope you find my suggestion fair enough.
With best regards
Create a Report
I was assuming that the destination workbook and the workbook containing this code, ThisWorkbook, are the same.
Adjust the values in the constants section.
Run only the createReport procedure. The function getFilePathsInFolder is being called by it.
Since ThisWorkbook will not have an "xlsx" extension, the statement If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then is redundant, but I'm leaving it because you might one day change the file extension to "xls*" when the code could do some damage.
Abstract
It will look in the specified folder and write all .xlsx files to an array. It will loop through the array and open each workbook to copy the picture, specified by its index, and paste it and write the specified cell values, to the specified locations of the destination workbook, closing each source workbook afterwards.
The Code
Option Explicit
Sub createReport()
Const ProcName As String = "createReport"
On Error GoTo clearError
' Source
Const Extension As String = "xlsx"
Const srcName As String = "sheetwithimage"
Const srcList As String = "A1,A2,A3" ' add more
Const picIndex As Long = 1
' Destination
Const dstName As String = "Sheet1"
Const dstList As String = "B1,B2,B3" ' add more
Const picAddress As String = "B7"
Const colOffset As Long = 5
' Write file paths from Source Folder Path to File Paths array.
Dim wbDst As Workbook: Set wbDst = ThisWorkbook
Dim srcFolderPath As String: srcFolderPath = wbDst.Path
Dim FilePaths As Variant
FilePaths = getFilePathsInFolder(srcFolderPath, Extension)
Dim srcCells() As String: srcCells = Split(srcList, ",")
Dim dstCells() As String: dstCells = Split(dstList, ",")
' Use a variable for lower and upper if inside another loop.
' Split ensures that lower is 0, so no need for lower variable.
Dim CellsUB As Long: CellsUB = UBound(srcCells) ' or 'Ubound(dstCells)'
Dim dst As Worksheet: Set dst = wbDst.Worksheets(dstName)
Dim dstFilePath As String: dstFilePath = wbDst.FullName
' Declare new variables occurring in the following loop.
Dim wbSrc As Workbook
Dim src As Worksheet
Dim srcCount As Long
Dim fp As Long
Dim n As Long
Application.ScreenUpdating = False
' We don't care if 'FilePaths' is zero, one or five-based, since we
' cannot use fp because of 'ThisWorkbook'; hence 'srcCount'.
For fp = LBound(FilePaths) To UBound(FilePaths)
' We have to skip 'ThisWorkbook'. Using 'StrComp' with 'vbTextCompare'
' is a great way for comparing strings case-insensitively i.e. 'A=a'.
' '0' means it is a match.
If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then
Set wbSrc = Workbooks.Open(FilePaths(fp), True, True)
Set src = wbSrc.Worksheets(srcName)
src.Pictures(picIndex).Copy
dst.Range(picAddress).Offset(, srcCount * colOffset).PasteSpecial
For n = 0 To CellsUB ' 'Split'
dst.Range(dstCells(n)).Offset(, srcCount * colOffset).Value _
= src.Range(srcCells(n)).Value
Next n
wbSrc.Close SaveChanges:=False
srcCount = srcCount + 1
End If
Next fp
' Save and/or inform user.
If srcCount > 0 Then
dst.Range("A1").Select
wbDst.Save
Application.ScreenUpdating = True
If srcCount = 1 Then
MsgBox "Data from 1 workbook transferred.", vbInformation, "Success"
Else
MsgBox "Data from " & srcCount & " workbooks transferred.", _
vbInformation, "Success"
End If
Else
MsgBox "No matching workbooks found in folder '" & srcFolderPath _
& "'!", vbCritical, "Fail"
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Function getFilePathsInFolder( _
FolderPath As String, _
Optional ByVal ExtensionPattern As String = "", _
Optional ByVal FirstIndex As Long = 0) _
As Variant
Const ProcName As String = "listFilePathsInFolder"
On Error GoTo clearError
With CreateObject("Scripting.FileSystemObject")
Dim fsoFolder As Object
Set fsoFolder = .GetFolder(FolderPath)
Dim FilesCount As Long
FilesCount = fsoFolder.Files.Count
If FilesCount > 0 Then
Dim n As Long
n = FirstIndex - 1
Dim OneD As Variant
ReDim OneD(FirstIndex To FilesCount + n)
Dim fsoFile As Object
If ExtensionPattern = "" Then
For Each fsoFile In fsoFolder.Files
n = n + 1
OneD(n) = fsoFile.Path
Next fsoFile
getFilePathsInFolder = OneD
Else
For Each fsoFile In fsoFolder.Files
If LCase(.GetExtensionName(fsoFile)) _
Like LCase(ExtensionPattern) Then
n = n + 1
OneD(n) = fsoFile.Path
End If
Next fsoFile
If n > FirstIndex - 1 Then
ReDim Preserve OneD(FirstIndex To n)
getFilePathsInFolder = OneD
Else
Debug.Print "'" & ProcName & "': " _
& "No '" & ExtensionPattern & "'-files found."
End If
End If
Else
Debug.Print "'" & ProcName & "': " _
& "No files found."
End If
End With
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function

Open excel workbooks starting with specific string listed down in cells

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

Excel VBA check if sheet exists and if yes add numeric to sheet name

I would like to say i'm an intermediate user of Excel VBA but i'm struggling with this one.
I have written a script to read a text file and strip out all the information I need and then add it to Worksheet that is named by the text file name and then todays date.
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
' Roll the number here
End If
Else
WS2.Name = strNewSheetName
End If
I use this function to check if it exists
Function CheckIfSheetExists(SheetName) As Boolean
CheckIfSheetExists = False
Err.Clear
On Error Resume Next
Set WS99 = Sheets(SheetName)
If Err = 0 Then
CheckIfSheetExists = True
Else
CheckIfSheetExists = False
End If
End Function
When I first wrote the code I was going to add a time to the sheet name but it will sometimes push the name over the 31 character limit.
So I would like some guidance on how I can add a numeric to the end of the sheet name and then repeat the process to see if that sheet name exists and then move it up a number and then check again.
Thank you in advance
Andy
This will name the sheets as, for example:
Test 03-05-18 and then Test 03-05-18_01 up to Test 03-05-18_99.
Update this line to allow more copies:
TempShtName = SheetName & "_" & Format(lCounter, "00")
There's one procedure and two functions in the code:
The first is a copy of your code (with variables declare).
The second figures out the name of the sheet.
The third checks if the sheet exists.
Public Sub Test()
Dim WrkBk As Workbook
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myFile As String
Dim myFileName As String
myFile = Application.GetOpenFilename()
'File name including extension:
'myFileName = Mid(myFile, InStrRev(myFile, "\") + 1)
'File name excluding extension:
myFileName = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
With ThisWorkbook
Set WS1 = .Sheets("Home")
WS1.Copy After:=.Worksheets(.Worksheets.Count)
Set WS2 = .Worksheets(.Worksheets.Count)
WS2.Name = GetSheetName(myFileName & " - " & Format(Now, "dd-mm-yy"))
End With
End Sub
'Return a numbered sheet name (or the original if it's the first).
Public Function GetSheetName(SheetName As String, Optional WrkBk As Workbook) As String
Dim wrkSht As Worksheet
Dim TempShtName As String
Dim lCounter As Long
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
TempShtName = SheetName
Do While WorkSheetExists(TempShtName)
lCounter = lCounter + 1
TempShtName = SheetName & "_" & Format(lCounter, "00")
Loop
GetSheetName = TempShtName
End Function
'Check if the sheet exists.
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Edit:
To remove illegal characters and keep the sheet name to 31 characters you could add this code in the GetSheetName function just before the TempShtName = SheetName line:
Dim x As Long
Dim sChr As String
Const ILLEGAL_CHR As String = "\/*?:[]"
For x = 1 To Len(SheetName)
sChr = Mid(SheetName, x, 1)
If InStr(ILLEGAL_CHR, sChr) > 0 Then
SheetName = Replace(SheetName, sChr, "_")
End If
Next x
If Len(SheetName) > 28 Then
SheetName = Left(SheetName, 28)
End If
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
'======Here's the new bit=================
Dim x as integer
x = 1
Do
strnewsheetname = left(strnewsheetname,30) & x
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
x = x +1
Loop while blnSheetCheck
WS2.Name = strNewSheetName
'=============End of New Bit=============
End If
Else
WS2.Name = strNewSheetName
End If
Technically this will keep looping above 9, but from you've said I don't think this will be a problem

Resources