I want to open one or more Excel files from a folder.
The macro should check if the value from three different cells are not zero.
If not, macro should open the file based on the cell value.
How do I open multiple files based on cell value?
Public Sub OpenFile1(MyRow, MyCol+1)
If Cells(MyRow, MyCol+1).Value <> "" Then
Workbooks.Open Path & Name
End If
End Sub
Public Sub OpenFile2(MyRow, MyCol+2)
If Cells(MyRow, MyCol+2).Value <> "" Then
Workbooks.Open Path & Name
End If
End Sub
Public Sub OpenFile3(MyRow, MyCol+3)
If Cells(MyRow, MyCol+3).Value <> "" Then
Workbooks.Open Path & Name
End If
End Sub
Sub openbutton1()
Call OpenFile1(6, 36)
Call OpenFile2(6, 36)
Call OpenFile3(6, 36)
End Sub
Open Workbooks From a List (Range)
Sub OpenFilesTEST()
Const RangeAddress As String = "AK6:AM6"
Const FolderPath As String = "C:\Test\"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range(RangeAddress)
OpenFiles rg, FolderPath
End Sub
Sub OpenFiles(ByVal rg As Range, ByVal FolderPath As String)
Const ProcName As String = "OpenFiles"
On Error GoTo ClearError
Dim cFilesCount As Long
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
Application.ScreenUpdating = False
Dim Cell As Range
Dim cString As String
Dim cFileName As String
For Each Cell In rg.Cells
cString = CStr(Cell.Value)
If Len(cString) > 0 Then ' not blank
cFileName = Dir(FolderPath & cString)
If Len(cFileName) > 0 Then ' file found
Workbooks.Open FolderPath & cFileName
cFilesCount = cFilesCount + 1
'Else ' file not found; do nothing
End If
'Else ' blank; do nothing
End If
Next Cell
ProcExit:
Application.ScreenUpdating = True
MsgBox "Number of files opened: " & cFilesCount, vbInformation
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Create a list with the three checks,
-if list empty do nothing
-else foreach item in list open corresponding book?
I might have misunderstood something though.
Related
I need help to handle runtime error 9.
My goals is to create a new workbook that compile specific sheet (Master User) from all excel workbook in a folder.
I'm stuck while using "on error goto" because i don't get it how to set the program while error (sheet doesn't exist) goto next workbook.
My code now cause me stuck in an never ending loop on a workbook that didn't have "master user" sheet
Sub Master()
Dim MyFiles As String
Dim Path As String
Dim myExtension As String
Dim Filename As String
Workbooks.Add.SaveAs Filename:="Master", FileFormat:=51
Path = "D:\My Document\"
myExtension = "*.xls*"
MyFiles = Dir(Path & myExtension)
On Error GoTo test
DoAgain:
Do While MyFiles <> ""
Workbooks.Open (Path & MyFiles)
Sheets("master user").Select
ActiveSheet.Rows(1).Copy
Workbooks("Master.xlsx").Activate
Sheets.Add After:=Sheets(Sheets.Count)
Range("A1").PasteSpecial xlPasteAll
If InStr(MyFiles, ".") > 0 Then
Filename = Left(MyFiles, InStr(MyFiles, ".") - 1)
End If
ActiveSheet.Name = Filename
Workbooks(Filename).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False
MyFiles = Dir
Loop
Workbooks("Master.xlsx").Activate
ActiveWorkbook.Close SaveChanges:=True
test:
ActiveWorkbook.Close SaveChanges:=False
Resume DoAgain
ActiveWorkbook.Save
End Sub
Copy Worksheet Ranges From Multiple Workbooks to a New Workbook
The Workbooks
The workbook containing this code (ThisWorkbook).
The source workbook i.e. each workbook (file) found in the source folder.
The destination workbook i.e. a newly added workbook that will be copied to.
Description
This will copy the first row of a same-named worksheet of each workbook (file) found in a folder to a newly added (and renamed) worksheet (multiple) of a new workbook (one).
Option Explicit
Sub CreateMaster()
Const ProcName As String = "CreateMaster"
On Error GoTo ClearError
' Source
Const sFolderPath As String = "D:\My Document\" ' maybe a missing 's'?
Const sFilePattern As String = "*"
Const sExtensionPattern As String = ".xls*"
Const swsName As String = "Master User"
' Destination
Const dFileName As String = "Master.xlsx"
' You never mentioned the destination path ('Master.xlsx') so I chose
' the same path as the path of the workbook containing this code.
' Omitting this path will lead to unexpected results (errors).
Dim dFilePath As String: dFilePath = ThisWorkbook.Path & "\"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
' Check if the source folder exists.
If Len(Dir(sFolderPath, vbDirectory)) = 0 Then
MsgBox "The folder '" & sFolderPath & "' doesn't exist.", _
vbCritical, ProcName
Exit Sub
End If
' Return the paths of the files of the source folder in a collection.
Dim sFilePaths As Collection
Set sFilePaths = CollFilePaths(sFolderPath, sFilePattern, sExtensionPattern)
If sFilePaths Is Nothing Then ' no files found
MsgBox "No '" & sExtensionPattern & "'- files found in folder '" _
& sFolderPath & "'.", vbCritical, ProcName
Exit Sub
End If
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim sFilePath As Variant
Dim dwb As Workbook
Dim dws As Worksheet
Dim dwbCreated As Boolean
' Loop through the elements (file paths) of the collection.
For Each sFilePath In sFilePaths
Set swb = Workbooks.Open(sFilePath)
' Attempt to create a reference to the source worksheet.
On Error Resume Next
Set sws = swb.Worksheets(swsName)
On Error GoTo ClearError
If Not sws Is Nothing Then ' source worksheet exists
' Add a new worksheet/workbook.
If dwbCreated Then ' destination workbook created
Set dws = dwb.Worksheets _
.Add(After:=dwb.Sheets(dwb.Sheets.Count))
Else ' destination workbook not created
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
Set dws = dwb.Worksheets(1)
dwbCreated = True
End If
' Attempt to rename the destination worksheet.
On Error Resume Next
dws.Name = Left(swb.Name, InStrRev(swb.Name, ".") - 1)
On Error GoTo ClearError
' Copy source to destination.
sws.Rows(1).Copy dws.Rows(1)
Set sws = Nothing
'Else ' source worksheet doesn't exist
End If
swb.Close SaveChanges:=False
Next sFilePath
If dwbCreated Then
dwb.Worksheets(1).Activate
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath & dFileName, dFileFormat
Application.DisplayAlerts = True
dwb.Close
MsgBox "Master created.", vbInformation, ProcName
Else
MsgBox "Non of the opened workbooks contained a worksheet " _
& "named '" & swsName & "'.", vbExclamation, ProcName
End If
Application.ScreenUpdating = False
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the paths of the files of a folder in a collection.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*", _
Optional ByVal ExtensionPattern As String = "*") _
As Collection
Const ProcName As String = "CollFilePaths"
On Error GoTo ClearError
Dim pSep As String: pSep = Application.PathSeparator
Dim foPath As String: foPath = FolderPath
If Right(foPath, 1) <> pSep Then foPath = foPath & pSep
Dim ePattern As String: ePattern = ExtensionPattern
If Left(ePattern, 1) <> "." Then ePattern = "." & ePattern
Dim fiName As String: fiName = Dir(foPath & FilePattern & ePattern)
If Len(fiName) = 0 Then Exit Function
Dim coll As Collection: Set coll = New Collection
Do Until Len(fiName) = 0
coll.Add foPath & fiName
fiName = Dir
Loop
Set CollFilePaths = coll
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I am currently working on a VBA project. I have a workbook with multiple tabs from different workbooks. The names of all the tabs are the same, however since they come from different files, I would like to name them based on the filenames they are extracted from. The filenames are present in the cell EC1 of every tab. I would like to name all the sheets in the workbook based on the value present in cell EC1 of each individual sheet.
I have the following code:
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("EC1")
Next rs
End Sub
I have been getting a 1004 error from the above code.
I tried this code too:
Sub RenameSheet()
Dim xWs As Worksheet
Dim xRngAddress As String
Dim xName As String
Dim xSSh As Worksheet
Dim xInt As Integer
xRngAddress = Application.ActiveCell.Address
On Error Resume Next
Application.ScreenUpdating = False
For Each xWs In Application.ActiveWorkbook.Sheets
xName = xWs.Range(xRngAddress).Value
If xName <> "" Then
xInt = 0
Set xSSh = Nothing
Set xSSh = Worksheets(xName)
While Not (xSSh Is Nothing)
Set xSSh = Nothing
Set xSSh = Worksheets(xName & "(" & xInt & ")")
xInt = xInt + 1
Wend
If xInt = 0 Then
xWs.Name = xName
Else
If xWs.Name <> xName Then
xWs.Name = xName & "(" & xInt & ")"
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Some sheets do get renamed, however some do not. I have checked for duplicate sheet names, and there are none. I have also checked if the filename is in the correct range (cell), and it is present.
There might be problems with the value if it contains some special characters. The excel sheets can have some restrictions for their names, if thats the problem, my code could be the solution.
It cuts the string to a maximum length of 31 chars and deletes all the special chars which are not allowed in names.
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
sheetName = without_special_chars(rs.Range("EC1").Value)
If Len(sheetName) > 31 Then
sheetName = Left(sheetName, 31)
End If
rs.Name = sheetName
Next rs
End Sub
Function without_special_chars(text As String) As String
Dim i As Integer
Const special_chars As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{"
For i = 1 To Len(special_chars)
text = Replace(text, Mid(special_chars, i, 1), "")
Next i
without_special_chars = text
End Function
Rename Multiple Worksheets
A Quick Fix
Your first code should have been something like this:
Sub renameWorksheetsQF()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Name = ws.Range("EC1").Value
Next ws
End Sub
Note the not so subtile differences.
In Depth
Option Explicit
Sub renameWorksheets()
On Error GoTo clearError
Const cAddress As String = "A1" ' "EC1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim cel As Range
Dim oName As String
Dim nName As String
For Each ws In wb.Worksheets
oName = ws.Name
Set cel = ws.Range(cAddress)
If IsError(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' contains the error value '" & cel.Text & "'."
Else
If IsEmpty(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' is an empty cell."
Else
nName = CStr(cel.Value)
On Error GoTo RenameError
If oName <> nName Then
ws.Name = nName
Else
Debug.Print "Worksheet '" & oName _
& "' had previously been renamed."
End If
On Error GoTo clearError
End If
End If
Next ws
ProcExit:
Exit Sub
RenameError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Could not rename '" & oName & "' to '" & nName & "'."
Resume Next
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Unexpected error."
Resume ProcExit
End Sub
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
I have previously posted on here about using VBA to loop through a folder and remove known passwords from each workbook therein. Thought I could use the same code and just insert code the removes all sheets except one (by reference to sheet name), but no such luck.
Any VBA pros out there that can help?
Sub loop_sheets_del()
Dim MyFile as String, str As String, MyDir = "[directory]"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While Myfile <> ""
Workbooks.Open (MyFile)
If ws.Name <> "name of sheet to keep" Then
ws.Delete
End If
Next ws (error indicates problem is here)
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop
End Sub
Delete Sheets
In the current setup, the following will delete all sheets except the one named Master in all files with the xls* extension (e.g. xls, xlsx, xlsm: do not use wild characters in the code; it is covered by Instr) in the specified folder F:\Test\2020\64504925 and all of its subfolders.
The Code
Option Explicit
' Run only this sub after you have adjusted the path, the worksheet name
' and the file extension.
Sub loopSubFolders()
Application.ScreenUpdating = False
loopSubFoldersInitialize "F:\Test\2020\64504925", "Master", "xls"
Application.ScreenUpdating = True
MsgBox "Sheets deleted.", vbInformation, "Success"
End Sub
Sub loopSubFoldersInitialize(ByVal FolderPath As String, _
ByVal SheetName As String, _
Optional ByVal FileExtension As String = "")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
loopSubFoldersRecursion fso, fso.GetFolder(FolderPath), SheetName, _
FileExtension
End Sub
Sub loopSubFoldersRecursion(fso As Object, _
fsoFolder As Object, _
ByVal SheetName As String, _
Optional ByVal FileExtension As String = "")
Dim fsoSubFolder As Object
Dim fsofile As Object
For Each fsoSubFolder In fsoFolder.SubFolders
loopSubFoldersRecursion fso, fsoSubFolder, SheetName, FileExtension
Next
If FileExtension = "" Then
For Each fsofile In fsoFolder.Files
'Debug.Print fsofile.Path
Next
Else
For Each fsofile In fsoFolder.Files
If InStr(1, fso.GetExtensionName(fsofile.Path), _
FileExtension, vbTextCompare) > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Open(fsofile.Path)
deleteSheetsExceptOneByName wb, SheetName
Debug.Print fsofile.Path
wb.Close SaveChanges:=True
End If
Next fsofile
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Deletes all sheets in a workbook except the one specified
' by its name.
' Remarks: The code uses the dictionary to hold all the sheet names.
' Only if the specified sheet exists, it will be removed from
' the dictionary and the remaining sheets in it will be deleted
' in one go. Otherwise no action will be taken.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function deleteSheetsExceptOneByName(Book As Workbook, _
ByVal SheetName As String) _
As Long
' Initialize error handling.
Const ProcName As String = "deleteSheetsExceptOneByName"
On Error GoTo clearError ' Turn on error trapping.
' Validate workbook.
If Book Is Nothing Then
GoTo NoWorkbook
End If
' Define dictionary.
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
' Write sheet names to dictionary.
Dim sh As Object
For Each sh In Book.Sheets
.Add sh.Name, Empty
Next sh
' Validate sheet name string.
If Not .Exists(SheetName) Then
GoTo NoSheet
End If
' Remove sheet name string from the dictionary.
.Remove (SheetName)
' Validate number of sheets.
If .Count = 0 Then
GoTo OneSheet
End If
' Delete sheets.
Application.DisplayAlerts = False
Book.Sheets(.Keys).Delete
Application.DisplayAlerts = True
deleteSheetsExceptOneByName = .Count
GoTo SheetsDeleted
End With
NoWorkbook:
Debug.Print "'" & ProcName & "': No workbook ('Nothing')."
GoTo ProcExit
NoSheet:
Debug.Print "'" & ProcName & "': No sheet named '" & SheetName _
& "' in workbook."
GoTo ProcExit
OneSheet:
Debug.Print "'" & ProcName & "': Sheet '" & Book.Sheets(SheetName).Name _
& "' is the only sheet in workbook."
GoTo ProcExit
SheetsDeleted:
If deleteSheetsExceptOneByName > 1 Then
Debug.Print "'" & ProcName & "': Deleted " _
& deleteSheetsExceptOneByName & " sheets in workbook."
Else
Debug.Print "'" & ProcName & "': Deleted 1 sheet in workbook."
End If
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
ProcExit:
End Function
You're missing the first part of the requisite For Each loop.
Also best to use a Workbook variable to refer to each workbook being opened and modified:
Do While Myfile <> ""
Dim MyWB As Workbook
Set MyWB = Workbooks.Open(MyFile)
For Each ws in MyWB.Worksheets
If ws.Name <> "name of sheet to keep" Then
ws.Delete
End If
Next
myWB.Close True
MyFile = Dir
Loop
Just for the sake of completeness I added the code and checked if the sheet to be kept exists so in case it doesn't, there isn't an error raised.
Read the code's comments.
Public Sub DeleteSheetsExceptInFiles()
Dim targetFile As String
Dim targetDirectory As String
Dim keepSheetName As String
Dim str As String
' Basic error handling
On Error GoTo CleanFail
' Define directory, file and sheet name
targetDirectory = "C:\Temp\"
targetFile = Dir(targetDirectory & "*.xlsx")
keepSheetName = "name of sheet to keep"
' Speed up process
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Loop through files
Do While targetFile <> ""
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(targetDirectory & targetFile)
' Check if sheet to keep exists
Dim targetSheet As Worksheet
Dim keepSheetExists As Boolean
On Error Resume Next
keepSheetExists = targetWorkbook.Worksheets(keepSheetName)
On Error GoTo CleanFail
' Proceed if sheet exists
If keepSheetExists = True Then
For Each targetSheet In targetWorkbook.Worksheets
' Delete all sheets except the one to keep
If targetSheet.Name <> keepSheetName Then
targetSheet.Delete
End If
Next targetSheet
End If
targetWorkbook.Close True
targetFile = Dir()
Loop
CleanExit:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
Solution Template SetUp
Been scratching around for the last 5 days here and across the net to find something that works for multiple files. Many a late night/early hours of the morning unsuccessfully piecing together/coding to get a result. Thanks in advance.
The following code is from get-digital-help.com/copyrename-a-file-excel-vba written by Oscar
It works for 1 file, Ive got 8,000 files to do across a deep folder structure so but I'd really like each row to look at a source path, source file name, destination path and destination file:
For each row:
Column A list the source path
Column B lists the source file name
Column C lists to destination path
Column D lists the new file name
Column E writes "Success" or "Fail" validation.
if file name already exists in destination, then "Fail"
If source file doesn't exist, then "Fail"
Nice to have/completely optional!!! :)
Check if source file column A&B exists, = True or False in column F. Where True, then proceed with copy and rename.
If destination file already exist, the fail and column F = duplicate
Leave first row to put in column header names.
Sub CopyRenameFile()
'Dimension variables and declare data types
Dim src As String, dst As String, fl As String
Dim rfl As String
'Save source directory specified in cell A2 to variable src
src = Range("A2")
'Save destination directory specified in cell C2 to variable dst
dst = Range("C2")
'Save file name specified in cell B2 to variable fl
fl = Range("B2")
'Save new file name specified in cell D2 to variable rfl
rfl = Range("D2")
'Enable error handling
On Error Resume Next
'Copy file based on variables src and fl to destination folder based on variable dst and name file based on value in rfl
FileCopy src & "\" & fl, dst & "\" & rfl
'Check if an error has occurred
If Err.Number <> 0 Then
'Show error using message box
MsgBox "Copy error: " & src & "\" & rfl
End If
'Disable error handling
On Error GoTo 0
End Sub
Copy Files Using a File List
This solution consists of three procedures. You run only the first: copyRenameFile. The other two, getOffsetColumn and writeOffsetRange are being called by the first, when necessary.
It is best tested with a new workbook. Insert a module and copy the code into it. Now open your original workbook and copy certain values to e.g. Sheet1 of the new workbook. Since the code is written for Thisworkbook (the workbook containing this code), the original workbook will be safe (will not be written to).
First adjust the values in the constants sections (titled Worksheet and Other). Then test the empty worksheet. Then test with one folder in column A then with more and slowly continue testing with other columns. Possible errors should be suppressed and their messages (descriptions) should appear in VBE's Immediate window (CTRL+G).
As a byproduct of this investigation, I've also added the createFolders function to create folders in one case when MkDir 'cannot', and two procedures to test it.
The Code
Option Explicit
Sub copyRenameFile()
' Initialize error handling.
Const ProcName As String = "copyRenameFile"
On Error GoTo clearError ' Turn on error trapping.
' Worksheet
Const wsName As String = "Sheet1" ' Worksheet Name
Const FirstRow As Long = 2 ' First Row Number
Const LastRowCol As Variant = "A" ' Last Row Column Index
Dim srcCols As Variant ' Source Columns Array
srcCols = VBA.Array("A", "B", "C", "D")
Dim tgtCols As Variant ' Target Columns Array
tgtCols = VBA.Array("E", "F")
' Other
Dim filMsg() As Variant ' File Messages
filMsg = VBA.Array("Fail", "Success")
Dim folMsg() As Variant ' Folder Messages
folMsg = VBA.Array(False, True, "Duplicate")
Dim PathDelimiter As String
PathDelimiter = Application.PathSeparator
Dim wb As Workbook
Set wb = ThisWorkbook ' 'Thisworkbook' is the workbook containing this code.
' Define Last Row Column Range ('rng').
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
If LastRow < FirstRow Then
GoTo FirstRowBelowLastRow
End If
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, LastRowCol), _
ws.Cells(LastRow, LastRowCol))
' Write Source Column Ranges to Source Jagged Array ('Source').
Dim ubcS As Long
ubcS = UBound(srcCols)
Dim Source As Variant
ReDim Source(0 To ubcS)
Dim Data As Variant
Dim j As Long
For j = 0 To ubcS
getOffsetColumn Data, srcCols(j), rng
Source(j) = Data
Next j
' Define Target Jagged Array ('Target').
Dim ubcT As Long
ubcT = UBound(tgtCols)
Dim ubs As Long
ubs = UBound(Source(0))
Dim Target As Variant
ReDim Target(0 To ubcT)
ReDim Data(1 To ubs, 1 To 1)
For j = 0 To ubcT
Target(j) = Data
Next j
' Declare additional variables for the For Next loop.
Dim i As Long
Dim Copied As Long
Dim srcPath As String
Dim tgtPath As String
' Loop through rows of arrays of Source Jagged Array, check folders,
' check files and finally copy if condition is met. At the same time
' write results to arrays of Target Jagged Array.
' The condition to copy is met when source file exists,
' and target file does not.
For i = 1 To ubs
' Folders
srcPath = Source(0)(i, 1)
If Dir(srcPath, vbDirectory) = "" Then
' Source Folder and Source File do not exist.
Target(0)(i, 1) = filMsg(0)
Target(1)(i, 1) = folMsg(0)
GoTo NextRow
End If
' Source Folder exists.
tgtPath = Source(1)(i, 1)
If Dir(tgtPath, vbDirectory) = "" Then
' Target Folder and Target File do not exist.
Target(0)(i, 1) = filMsg(0)
Target(1)(i, 1) = folMsg(0)
GoTo NextRow
End If
' Source Folder and Target Folder exist.
' Files
srcPath = srcPath & PathDelimiter & Source(2)(i, 1)
If Dir(srcPath) = "" Then
' Source File does not exist.
Target(0)(i, 1) = filMsg(0)
Target(1)(i, 1) = folMsg(0)
GoTo NextRow
End If
' Source File exists.
tgtPath = tgtPath & PathDelimiter & Source(3)(i, 1)
If Dir(tgtPath) <> "" Then
' Target File exists.
Target(0)(i, 1) = filMsg(0)
Target(1)(i, 1) = folMsg(2)
GoTo NextRow
End If
' Source File exists and Target File does not.
Target(0)(i, 1) = filMsg(1)
Target(1)(i, 1) = folMsg(1)
' Copy
FileCopy srcPath, tgtPath
' Count files copied.
Copied = Copied + 1
NextRow:
Next i
' Write values (results) from arrays of Target Jagged Array
' to Target Columns.
For j = 0 To ubcT
writeOffsetRange Target(j), tgtCols(j), rng
Next j
' Inform user.
MsgBox "Copied " & Copied & " files.", vbInformation, "Success"
ProcExit:
Exit Sub
FirstRowBelowLastRow:
Debug.Print "'" & ProcName & "': First row below last row."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Sub getOffsetColumn(ByRef Data As Variant, _
OffsetColumnIndex As Variant, _
ColumnRange As Range)
' Initialize error handling.
Const ProcName As String = "getOffsetColumn"
On Error GoTo clearError ' Turn on error trapping.
Data = Empty
If ColumnRange Is Nothing Then
GoTo NoRange
End If
Dim ws As Worksheet
Set ws = ColumnRange.Worksheet
If ColumnRange.Rows.Count > 1 Then
Data = ColumnRange.Offset(, ws.Columns(OffsetColumnIndex).Column _
- ColumnRange.Column) _
.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = ColumnRange.Offset(, ws.Columns(OffsetColumnIndex) _
.Column _
- ColumnRange.Column) _
.Value
End If
ProcExit:
Exit Sub
NoRange:
Debug.Print "'" & ProcName & "': No Range."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Sub writeOffsetRange(Data As Variant, _
OffsetColumnIndex As Variant, _
ColumnRange As Range)
' Initialize error handling.
Const ProcName As String = "writeOffsetColumn"
On Error GoTo clearError ' Turn on error trapping.
If ColumnRange Is Nothing Then
GoTo NoRange
End If
Dim ws As Worksheet
Set ws = ColumnRange.Worksheet
ColumnRange.Offset(, ws.Columns(OffsetColumnIndex).Column _
- ColumnRange.Column).Value = Data
ProcExit:
Exit Sub
NoRange:
Debug.Print "'" & ProcName & "': No Range."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
The Byproduct
' e.g. "C:\Test" is an existing folder, "C:\Test\Test1" is not.
' When you want to create the folder "C:\Test\Test1\Test2", 'MkDir' will return
' "Run-time error '76': Path Not found", because "C:\Test\Test1" does not exist.
' The 'createFolders' function remedies this by creating as many folders
' as needed. In the previous example it first creates "C:\Test\Test1" and
' only then creates "C:\Test\Test1\Test2" in it.
' The function returns 'True' if the folder previously existed or now exists.
' The function returns 'False' if 'PathString' is invalid.
Function createFolders(PathString As String) As Boolean
' Initialize error handling.
Const ProcName As String = "createFolders"
On Error GoTo clearError ' Turn on error trapping.
' Split Path String ('PathString') by System Path Separator ('Delimiter')
' into 1D zero-based Folders Array 'Folders()'.
Dim Delimiter As String
Delimiter = Application.PathSeparator
Dim Folders() As String
Folders = Split(PathString, Delimiter)
' Define Last Subscript ('LastSS') to be considered, because Path String
' could be ending with a System Path Separator.
Dim LastSS As Long
LastSS = UBound(Folders)
If Folders(LastSS) = "" Then
LastSS = LastSS - 1
End If
' Using Folders Array, write paths to Paths Array ('Paths()').
Dim Paths() As String
ReDim Paths(0 To LastSS)
Paths(0) = Folders(0)
Dim j As Long
If LastSS > 0 Then
For j = 1 To LastSS
Paths(j) = Paths(j - 1) & Delimiter & Folders(j)
Next j
End If
' Create each folder if it does not exist.
For j = 0 To LastSS
If Dir(Paths(j), vbDirectory) = "" Then
MkDir Paths(j)
End If
Next j
' Write result.
createFolders = True
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function
Sub testCreateFolders()
Const PathString As String = "C:\Test\Test1\Test2"
Dim Result As Boolean
Result = createFolders(PathString)
If Result Then
MsgBox "If the path previously didn't exist, now it certainly does."
Else
MsgBox "The supplied path is invalid."
End If
End Sub
Sub testMkDir()
Const PathString As String = "C:\Test\Test1\Test2"
MkDir PathString
End Sub