Using Excel 2013 macros I'd like to be able to, upon worksheet creation (the "+" sign or right click, new worksheet), to instead of creating a new worksheet, copy a hidden "TEMPLATE" worksheet instead to use as a template for this workbook. There will be many worksheets to be created initially and over time, this workbook will be used every day with potentially other workbooks open at the same time as well.
The code I already have asks for the user to input the name of the worksheet upon creation and calls to sort the current workbook's worksheets alphanumerically and rebuild the TOC. Is there any way to change the current code to match it's new purpose? NOTE: This code is in ThisWorkbook.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim sName As String
Dim bValidName As Boolean
Dim i As Long
bValidName = False
Do While bValidName = False
sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name)
If Len(sName) > 0 Then
For i = 1 To 7
sName = Replace(sName, Mid(":\/?*[]", i, 1), " ")
Next i
sName = Trim(Left(WorksheetFunction.Trim(sName), 31))
If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True
End If
Loop
Sh.Name = sName
Call Sort_Active_Book
Call Rebuild_TOC
End Sub
Edit 1:
Note: The "TEMPLATE" worksheet only pertains to this workbook, does not need to be used in another workbook, and is a hidden worksheet in this workbook.
Updated code. GSerg has it right:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim wb as Workbook
Dim wsTemp as Worksheet
Dim sName As String
Dim bValidName As Boolean
Dim i As Long
bValidName = False
Do While bValidName = False
sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name)
If Len(sName) > 0 Then
For i = 1 To 7
sName = Replace(sName, Mid(":\/?*[]", i, 1), " ")
Next i
sName = Trim(Left(WorksheetFunction.Trim(sName), 31))
If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True
End If
Loop
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set wsTemp = wb.Sheets("TEMPLATE")
wsTemp.Visible = xlSheetVisible
wsTemp.Copy After:=wb.Sheets(wb.Sheets.Count)
ActiveSheet.Name = sName
Sh.Delete
wsTemp.Visible = xlSheetHidden 'Or xlSheetVeryHidden
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Call Sort_Active_Book
Call Rebuild_TOC
End Sub
Is your template saved a location you could pull from for anyone who needs it? If not you will just have to create a macro to format a template.
If you have a template ready, you just need the full path of that file. I would turn off application.screenupdating = false and open that file, copy the sheet you want and paste it to your current doc, then close the template file and application.screenupdating = true.
Edit:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Template").Visible = True
sheets("Template").copy after:=Sheets(1)
Sheets("Template").Visible = False
ActiveSheet.Name = sName
Sheets(Sh.Name).Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
This will work, you will just need to change the template path
Related
I have a blank master sheet(C:\path1\path2\overdue.xlsm) it has
column headers and a macro button
-the data pulled from other workbooks will start in row 2
-the macro needs to open an excel file (C:\path1\path2\path3\project1.xlsx)
-check for 2 text criteria
- -a "Y" (Static cell B7)
- -an "OVERDUE" (Range of cells always starts B16) range of 4+ cells to check
-If it matches both criteria it will copy various cells from the worksheet
-it needs to paste the copied cells but transposed into the next available row on master sheet(C:\path\path\overdue.xlsm)
-then closes the excel file without saving the changes (C:\path1\path2\path3\project1.xlsx)
-it needs to loop this macro through all of the subfolders within (C:\path1\path2) , each project has its own folder, each folder has
its own xlsx file along with other project files(this is why the xlsx
files are all in different folders)
1st code- for file check
I run this macro in a template that has header columns. The returned info starts populating on row 2. It generates a list based on other workbooks. This code opens each file within a specified folder, checks for certain criteria, then generates a list if the criteria is met. Then closes the file. This works well if all of the files are in the same folder.
Sub OVERDUEcheck()
Dim sPath As String, sName As String
Dim bk As Workbook 'opened from the folder
Dim src As Worksheet 'sheet to retrieve data from
Dim sh As Worksheet 'the sheet with the command button
Dim rw As Long 'the row to write to on sh
Dim lr As Long 'last row col A of src sheet
Dim i As Integer 'for looping rows to look at
Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs
rw = 2 ' which row to write to in the activesheet
sPath = "C:\Box Sync\LocateRequests\" ' Path for file location
sName = Dir(sPath & "*.xls")
Do While sName <> "" 'Loop until filename is blank
Set bk = Workbooks.Open(sPath & sName)
Set src = bk.Worksheets(2)
With src
If .Range("B7").Text = "Y" Then
lr = .Range("A" & Rows.Count).End(xlUp).Row
For i = 16 To lr
If .Cells(i, "B").Text = "OVERDUE" Then
sh.Cells(rw, "A") = .Range("b5")
sh.Cells(rw, "B") = .Range("b6")
sh.Cells(rw, "C") = .Range("b10")
sh.Cells(rw, "D") = .Range("b11")
sh.Cells(rw, "E") = .Range("a" & i)
sh.Cells(rw, "F") = .Range("B12")
rw = rw + 1
End If
Next i
End If
End With
bk.Close SaveChanges:=False
sName = Dir()
Loop ' loop until no more files
End Sub
This 2nd code is something I found with google, it is code for looping other functions through folders and subfolders.
Public Sub openWB() Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\WYMAN\Desktop\testDel"
Set folder = FSO.GetFolder(folderPath)
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With
For Each wb In folder.Files
If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or
Right(wb.Name, 4) = "xlsm" Then
Set masterWB = Workbooks.Open(wb)
'Modify your workbook
ActiveWorkbook.Close True
End If
Next
For Each subfolder In folder.SubFolders
For Each wb In subfolder.Files
If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or
Right(wb.Name, 4) = "xlsm" Then
Set masterWB = Workbooks.Open(wb)
'Modify your workbook
ActiveWorkbook.Close True
End If
Next
Next
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With End Sub
Thanks
i think there is best way, to avoid reconstruct your code, your first function, you can do it a function with the path as a param
Sub OVERDUEcheck(sPath As String)
Dim sName As String
Dim bk As Workbook 'opened from the folder
Dim src As Worksheet 'sheet to retrieve data from
Dim sh As Worksheet 'the sheet with the command button
Dim rw As Long 'the row to write to on sh
Dim lr As Long 'last row col A of src sheet
Dim i As Integer 'for looping rows to look at
Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs
rw = 2 ' which row to write to in the activesheet
sName = Dir(sPath & "*.xls")
Do While sName <> "" 'Loop until filename is blank
Set bk = Workbooks.Open(sPath & sName)
Set src = bk.Worksheets(2)
With src
If .Range("B7").Text = "Y" Then
lr = .Range("A" & Rows.Count).End(xlUp).Row
For i = 16 To lr
If .Cells(i, "B").Text = "OVERDUE" Then
sh.Cells(rw, "A") = .Range("b5")
sh.Cells(rw, "B") = .Range("b6")
sh.Cells(rw, "C") = .Range("b10")
sh.Cells(rw, "D") = .Range("b11")
sh.Cells(rw, "E") = .Range("a" & i)
sh.Cells(rw, "F") = .Range("B12")
rw = rw + 1
End If
Next i
End If
End With
bk.Close SaveChanges:=False
sName = Dir()
Loop ' loop until no more files
End Sub
then in your second code, send the subdirectories to every subpath:
Public Sub openWB() Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\WYMAN\Desktop\testDel"
Set folder = FSO.GetFolder(folderPath)
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With
OVERDUEcheck(folderPath)
For Each subfolder In folder.SubFolders
OVERDUEcheck(subfolder.name)
Next
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With End Sub
There is time i don't use VBA, maybe a miss some detail, but that is the idea.
Make big functions can confuse a lot, so i think is better divide the code with an idea or concept, and call it instead a big one, and is easy to change/edit in future, will be more intuitive, even you can make a function for file, then a function for folders.
In this cases i recommend you instead use a sub, use a function, like return 0 if is fine, and 1 if not, and in the function use "On Error" for error handle, to know if something fails, record the folder and continues working.
Cya.
I would like to save the worksheets in a workbook to specified folder locations.
The conditions will be based on the worksheet name based on this example table in one of the worksheet in the current workbook. There is a possibility to add on to the naming conventions table..
*assume the folders are located in the same path as current workbook.
Currently i only have this code, which is saving to current path..
Sub ExportToWorkbooks()
Dim NewBook As Workbook, OldBook As Workbook, sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set OldBook = ThisWorkbook
For Each sh In OldBook.Worksheets
If sh.Visible = True Then
sh.Copy
ActiveWorkbook.SaveAs Filename:=OldBook.Path & "\" & sh.Name, FileFormat:=xlWorkbookNormal
ActiveWorkbook.Close
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If the table is in a sheet named "MainSheet" and the folders specified in column C are inside the current path, the following might work. You should add errors handlers, for example in the case that the folder or the sheets specified in your table do not exist.
Option Explicit
Sub ExportToWorkbooks()
Dim OldBook As Workbook
Dim LastRow As Long, i As Long
Dim TheSheetToSave As String, TheFileName As String, TheFilePath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set OldBook = ThisWorkbook
'Find last row of table
LastRow = OldBook.Worksheets("MainSheet").Cells(Rows.Count, 1).End(xlUp).Row
'Scan all rows of table
For i = 2 To LastRow 'Start in second row. First row for titles
TheSheetToSave = OldBook.Worksheets("MainSheet").Cells(i, 1).Value
TheFileName = OldBook.Worksheets("MainSheet").Cells(i, 2).Value
TheFilePath = OldBook.Worksheets("MainSheet").Cells(i, 3).Value
Worksheets(TheSheetToSave).Copy
ActiveWorkbook.SaveAs Filename:=OldBook.Path & "\" & TheFilePath & "\" & TheFileName, FileFormat:=xlWorkbookNormal
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I tried to create VBA macro in excel where one excel sheet tracks a path and creates a new tab in another sheet. It works well but when I create another tab "accidentally" with same name it gives me error as "Name already taken try another one". I don't want to create one more tab with same name. Instead it should stop me from creating tabs with same name
Is there anyway if there that name already exist it gives me a pop up saying name already exist I get only one option as ok to click. I click Ok and the additional sheet that is created doesn't get saved (or if already created deletes itself or save as same name with (2) next to it as excel usually do for repeated sheets). I am trying something like this
If wb.ActiveSheet.Name = sName Then wb.ActiveSheet.Delete
Here is my code
Private Sub Filling_List()
Dim sPath As String
Dim sFile As String
Dim wb As Workbook
Dim sName As String 'add sName declaration
Dim wb1 As Workbook
Dim ws1 As Worksheet
Set wb1 = ThisWorkbook
Set ws1 = ThisWorkbook.Worksheets("S0")
Application.ScreenUpdating = False
sPath = "C:\Users\arp\Desktop\Filling list macro\"
sFile = sPath & "ArF Filling List.xlsm"
Set wb = Workbooks.Open(sFile)
wb.Worksheets("ArF Templete").Copy After:=Worksheets(Worksheets.Count)
sName = ws1.Range("A1") & " " & ws1.Range("T2")
wb.ActiveSheet.Name = sName
'If wb.ActiveSheet.Name = sName Then wb.ActiveSheet.Delete "I am trying this but it doesn't work"
If sName = vbNullString Then Exit Sub 'compare against vbNullstring not empty string literal
With wb.Worksheets(sName)
.Cells(3, "E") = InputBox("Your Initials:")
'.Cells(5, "E") = InputBox("Col?:")
.Cells(6, "E") = InputBox("I:")
.Cells(7, "E") = InputBox("ET1 B:")
.Range("B03") = wb1.Worksheets("Que").Range("B02").Value2
.Range("B04") = wb1.Worksheets("Que").Range("E01").Value2
.Range("B05") = wb1.Worksheets("Que").Range("B01").Value2
.Cells(3, "E") = wb1.Worksheets("Que").Range("E02").Value2
.Cells(5, "E") = "Yes"
'Filling order
.Range("B38:B43") = wb1.Worksheets("Que & Tsc Cal").Range("B04:B09").Value2
.Range("C38:C43") = wb1.Worksheets("Que & Tsc Cal").Range("C04:C09").Value2
.Range("D38:D43") = wb1.Worksheets("Que & Tsc Cal").Range("A04:A09").Value2
'Retains
End With
Application.ScreenUpdating = True
End Sub
I developed above version with the help of you guys here and joining bits and pieces from other threads.Any suggestions to make it better are very welcome.
I use a check if the named tab/sheet is available:
If IsError(Evaluate("SHEETNAME!A1")) Then
'Nothing
Else
Sheets("SHEETNAME").Delete
End If
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Or as suggested by Scott to have it be simpler and cleaner:
If Not IsError(Evaluate("SHEETNAME!A1")) Then Sheets("SHEETNAME").Delete
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Edit 1:
Application.DisplayAlerts = False
If IsError(Evaluate("SHEETNAME!A1")) Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Application.DisplayAlerts = True
[W]hen I create another tab "accidentally" with same name it gives me error . . . I don't want to create one more tab with same name. Instead it should stop me from creating tabs with same name
This is not an uncommon problem with macros that create tabs--it is easy to accidentally run them twice. To prevent this, first check to see if the tab already exists and only after verifying that it doesn't exist, call the Worksheets.Copy method.
Private Sub Filling_List()
Dim sPath As String
Dim sFile As String
Dim wb As Workbook
Dim sName As String 'add sName declaration
Dim wb1 As Workbook
Dim ws1 As Worksheet
Set wb1 = ThisWorkbook
Set ws1 = ThisWorkbook.Worksheets("S0")
Application.ScreenUpdating = False
sPath = "C:\Users\arp\Desktop\Filling list macro\"
sFile = sPath & "ArF Filling List.xlsm"
Set wb = Workbooks.Open(sFile)
sName = ws1.Range("A1") & " " & ws1.Range("T2")
On Error Resume Next
Dim wslTest As Worksheet
Set wslTest = wb.Worksheets(sName)
If Err.Number = 0 Then
MsgBox "Tab: " & sName & " already exists.", vbInformation
wslTest.Activate
Exit Sub
End If
On Error GoTo 0
wb.Worksheets("ArF Templete").Copy After:=wb.Worksheets(wb.Worksheets.Count)
wb.ActiveSheet.Name = sName
' rest of code
End Sub
The code below should do what you want, you may need to adapt it for your project.
Option Explicit
Sub addsheet()
Dim sht As Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets.add
On Error Resume Next 'Prevent Excel from stopping on an error but just goes to next line
ws.Name = "Sheet1"
If Err.Number = 1004 Then
MsgBox "Worksheet with this name already exists"
Application.DisplayAlerts = False 'Prevent confirmation popup on sheet deletion
ws.Delete
Application.DisplayAlerts = True 'Turn alerts back on
On Error GoTo 0 'Stop excel from skipping errors
Exit Sub 'Terminate sub after a failed attempt to add sheet
End If
On Error GoTo 0 'Stop Excel from skipping errors.
End Sub
Below is code that allows the user to choose a folder and opens files within the folder. It essentially does this:
On open, look for filepath saved in worksheet in workbook based on username. If doesn't exist, then prompt user to find folder, then save filepath in worksheet
From step 1, if filepath is found based on user, use that filepath
Error handler: From step 1, if filepath is found based on user, but that filepath is not in use anymore(i.e. user moved the folder to a different filepath), then have user find the folder again, then update existing record
What i'm experiencing is this:
When there's no entries in the sheet, then it will prompt user to
find the folder, but then proceed to the errorhandler and ask the
user to find the folder again
When there are entries in the sheet and the file path is working, the errorhandler is still opened and asks the user to find the
folder again
If I take out the errorhandler, everything is smooth. It's just that I want to cover the possibility of the user moving the folder , so I want the workbook to prompt the user to find where they moved the folder, and update the existing record in the workbook to the new path
What am I doing wrong here?
Private Sub Workbook_Open()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim vafiles As Variant
Dim filepath As String
Dim filepath2 As String
Dim filepath3 As String
Dim rw As Long
Dim ws As Worksheet
Dim lastrow As Long
Dim icounter As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set ws = Worksheets("Paths")
rw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Extract")
'======================================================
'Determine if Path was already saved before. If not, prompt user to choose folder
'======================================================
sal = Application.VLookup(Environ("username"), ws.Range("a:b"), 2, 0)
If IsError(sal) Then
MsgBox ("Please choose where your main folder is located. This will be stored so you won't need to look for it again.")
filepath = PICK_A_FOLDER()
ws.Cells(rw, 2) = PICK_A_FOLDER()
ws.Cells(rw, 1) = Environ("username")
Set wkb2 = Workbooks.Open(filepath & "\ Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic
Else
'======================================================
'If filepath exists, use that one
'======================================================
filepath2 = sal
Set wkb2 = Workbooks.Open(filepath2 & "Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
End If
'======================================================
'If user has moved their folder, we can find it again and update their record
'======================================================
On Error GoTo Errorhandler
Errorhandler:
MsgBox ("Looks like you've moved your Folder. Please find it so your record will be updated")
filepath3 = PICK_A_FOLDER()
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For icounter = 2 To lastrow
If Cells(icounter, 1) = Environ("username") Then
Cells(icounter, 2) = PICK_A_FOLDER()
End If
Next icounter
Set wkb2 = Workbooks.Open(filepath3 & "")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic
End Sub
Actually solved this by taking out the errorhandler and inserting another if statement that captures an invalid directory:
if dir(sal & "Export.xlsx") = "" then
write error handler code
When a SubRoutine performs more that one task you should consider extracting the individual tasks into separate SubRoutines.
In this way:
You can debug each task independently of the other tasks
The logic is simplified into smaller units
The code is easier to read
You can reduce clutter by placing these SubRoutines into separate modules
Possible code reuse
Another unapparent benefit is that by simplifying the function of a SubRoutine it is much easier to remember the routines pattern and reuse the pattern when a similar situation arises.
Note: I often use If Len(...) then which is analogous to If Len(...) > 0 then. I do this to reduce clutter.
Standard Module
Function getSharedFolder() As String
Dim f As Range
With Worksheets("Paths")
Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
If Not f Is Nothing Then
'Dir([PathName], vbDirectory) returns empty if the [PathName] isn't a folder
If Len(Dir(f.Offset(0, 1).Value, vbDirectory)) Then
If Right(f.Offset(0, 1), 1) = "\" Then
getSharedFolder = f.Offset(0, 1)
Else
getSharedFolder = f.Offset(0, 1) & "\"
End If
End If
End If
End With
End Function
Function setSharedFolder() As Boolean
Dim f As Range
Dim PathName As String
PathName = PickSharedFolder
If Len(PathName) Then
setSharedFolder = True
With Worksheets("Paths")
Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
If f Is Nothing Then Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Offset(1)
f.Value = Environ("username")
f.Offset(0, 1) = PathName
End With
End If
End Function
Function PickSharedFolder() As String
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select Main Folder Location"
If .Show = -1 And .SelectedItems.Count = 1 Then
PickSharedFolder = .SelectedItems(1)
Else: Exit Function
End If
End With
End Function
Sub ToggleEvents(EnableEvents As Boolean, Optional DisplayAlerts = True)
With Application
.DisplayAlerts = DisplayAlerts
.EnableEvents = EnableEvents
.ScreenUpdating = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Sub UpdateWorkBook(FilePath As String)
Dim WSSource As Worksheet
With Workbooks.Open(FilePath)
Set WSSource = .Sheets("Sheet1")
If WSSource Is Nothing Then
MsgBox "Sheet1 not found in " & FILENAME, vbCritical, "Update Cancelled"
Else
WSSource.Copy Destination:=ThisWorkbook.Sheets("Extract").Range("A1")
End If
.Close True
End With
End Sub
Workbook Module
Private Sub Workbook_Open()
Const FILENAME As String = "Export.xlsx"
Const PROMPT As String = "Press [Yes] to continue or [No] to cancel"
Dim FilePath As String, Title As String, SharedFolder As String
ToggleEvents False, False
Do
SharedFolder = getSharedFolder()
If Len(SharedFolder) = 0 Then
Title = "Folder not found"
Else
FilePath = SharedFolder & FILENAME
If Len(Dir(FilePath)) = 0 Then Title = "File not found"
End If
If Len(SharedFolder) = 0 Then
If MsgBox(PROMPT:=PROMPT, Buttons:=vbYesNo, Title:=Title) = vbYes Then
setSharedFolder
Else
Exit Sub
End If
End If
Loop Until Len(Dir(FilePath))
UpdateWorkBook FilePath
ToggleEvents True, True
End Sub
I just started using VBA and I've been using a code to merge multiple worksheets into a single workbook, it works fine except for worksheets containing images. In these cases the image won't show in the new workbook created. It appears the box where the image should be with an error message. I use MS Office 2010.
Here follows the code I've been using:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Any idea of what is going on? I'd appreciate any help!
Tks!
just found a workaround that helped!
I just added "Application.ScreenUpdating = True" before closing the source workbook, it takes longer to merge all worsheets, but at least the images are displayed correctly!
Here follows the new code:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
**Application.ScreenUpdating = True**
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Found this workaround here - Option 1!
Tks Dan!