Everything in this code works fine, except at the very end when I go to close the workbook that I am performing some operations on. I'm inserting some code into ThisWorkbook of the workbook that I'm opening from a text file and also copying a few tabs in my master spreadsheet to each workbook that I open in this loop. At the end of the loop it crashes when I try to close and move on to the next workbook.
Sub AddSht_AddCode()
Dim wb As Workbook
Dim xPro As VBIDE.VBProject
Dim xCom As Variant
Dim xMod As VBIDE.CodeModule
Dim xLine As Long
Dim strFolderPath As String
Dim strFolderPathTo As String
Dim strCodePath As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim mergearea As Range
Dim c As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strFolderPath = Sheets("Master - DO NOT MOVE").Range("B2").Value
strCodePath = Sheets("Master - DO NOT MOVE").Range("b18").Value
If IsNull(strFolderPath) Or strFolderPath = "" Then
MsgBox "Please make sure you have a valid DFF path entered in Cell B2 on the Master worksheet.", vbOKOnly
Exit Sub
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Dir(strFolderPath, vbDirectory) = "" Then
MsgBox "The DFF folder path entered is not a valid path. Please edit and try again.", vbOKOnly
Exit Sub
Else
Set objFolder = objFSO.GetFolder(strFolderPath)
End If
'create_projid_array
'create_projid_new
For Each objFile In objFolder.Files
'If (InStr(objFile.Name, ".xlsm") > 0 Or InStr(objFile.Name, ".xlsx") > 0) And check_var_array(Left(objFile.Name, InStr(1, objFile.Name, ".") - 1), projarray) = 1 Then
'If (InStr(objFile.Name, ".xlsx") > 0 Or InStr(objFile.Name, ".xlsb") > 0) And check_var_array(Left(objFile.Name, InStr(1, objFile.Name, ".") - 1), projarray) = 1 Then
If (InStr(objFile.Name, ".xlsm") > 0) Then
'If check_var_array(objFile.Name, projarray) = 1 Then
Application.AutomationSecurity = msoAutomationSecurityLow
Set wb = Workbooks.Open(objFile, False)
'Application.AutomationSecurity = msoAutomationSecurityByUI
Workbooks("DFFPHI_w_QAQC.xlsm").Activate
If Right(objFile.Name, 5) = ".xlsx" Then
Sheets(Array("Template", "Log")).Copy After:=wb.Sheets(1)
If Sheets("Master - DO NOT MOVE").Range("B4") = True Then
wb.Activate
wb.Sheets("Data").UsedRange.Clear
wb.Sheets("Data").Range("A1").Value = 0
Workbooks("DFFPHI_w_QAQC.xlsm").Sheets("Data").Range("B1:BO2400").Copy Destination:=wb.Sheets("Data").Range("B1")
End If
End If
wb.Activate
wb.Sheets(1).Visible = xlSheetVisible
wb.Sheets(1).Unprotect Password:="xxxxxxxxx"
Set mergearea = wb.Sheets(1).Range("i5:l6")
For Each c In mergearea
If c.MergeCells Then
c.UnMerge
End If
Next
wb.Sheets(1).Range("J5").ClearContents
wb.Sheets(1).Range("j6").ClearContents
'Selection.UnMerge
'Selection.ClearContents
If Right(objFile.Name, 5) = ".xlsm" Then
wb.Sheets("Template").Visible = xlSheetVisible
wb.Sheets("Data").Visible = xlSheetVisible
Workbooks("DFFPHI_w_QAQC.xlsm").Activate
If Sheets("Master - DO NOT MOVE").Range("B4") = True Then
wb.Activate
wb.Sheets("Data").UsedRange.Clear
wb.Sheets("Data").Range("A1").Value = 0
Workbooks("DFFPHI_w_QAQC.xlsm").Sheets("Data").Range("B1:BO2400").Copy Destination:=wb.Sheets("Data").Range("B1")
End If
Workbooks("DFFPHI_w_QAQC.xlsm").Activate
If Sheets("Master - DO NOT MOVE").Range("B6") = True Then
wb.Activate
wb.Sheets("Template").UsedRange.Clear
Workbooks("DFFPHI_w_QAQC.xlsm").Sheets("Template").Range("A1:G524").Copy Destination:=wb.Sheets("Template").Range("A1")
If Left(wb.Sheets(1).Range("I7"), 3) = "PO " Or Left(wb.Sheets(1).Range("I7"), 3) = "PO#" Then
wb.Sheets(1).Range("I7").Copy Destination:=wb.Sheets("Template").Range("F3")
End If
End If
End If
wb.Activate
Call update_dropdowns
Call update_ga_formula(wb.Name)
wb.Sheets(Array("Template", "Data")).Select
ActiveWindow.SelectedSheets.Visible = False
wb.Activate
With wb
Set xPro = .VBProject
Set xCom = xPro.VBComponents("ThisWorkbook")
Set xMod = xCom.CodeModule
xMod.DeleteLines 1, _
xMod.CountOfLines
xMod.AddFromFile strCodePath
End With
wb.Activate
With wb.Sheets(1)
.Protect Password:="xxxxxxx", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, DrawingObjects:=False, Contents:=True, Scenarios:=True, AllowFiltering:=True
.EnableOutlining = True
End With
wb.Save
wb.Close <<<<<EXCEL CRASHES HERE>>>>>>>
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Just to finalize:
In my specific situation I was adding a BeforeClose Event to the target workbook ThisWorkbook object. In the code that is performing this operation, it was crashing after the BeforeClose code was inserted in the target workbook and upon having the source code try to close the workbook with wb.Close.
I changed:
wb.Close
to
Application.EnableEvents = False
wb.Close
Application.EnableEvents = True
So, bypassed the target workbook events altogether and it's fixed.
Check the code in the wb close / save events for any invalid actions:
BeforeClose()
BeforeSave()
SheetDeactivate()
WindowDeactivate(), etc
Not related, but remove the .Activate statements and qualify the objects if needed
For example:
Workbooks("DFFPHI_w_QAQC.xlsm").Activate
If Sheets("Master - DO NOT MOVE").Range("B4") = True Then
should be replaced with
If Workbooks("DFFPHI_w_QAQC.xlsm").Sheets("Master - DO NOT MOVE").Range("B4") = True Then
Statements .Select and .Activate are not needed and have poor performance
Related
i'm having a bit of a headache with VBA which i haven't used since 2006.
I have my destination excel file where I need to import 3 predefined sheets from another excel file of the user's choice.
After selecting the source file to import I would like to perform a check, IF the "Cover" sheet exists THEN copy it to the target workbook ELSE print an error message in the excel file in order to have a log, once this is done I have to do the same check for the "Functional" and "Batch" sheets.
Before inserting the IFs, I was able to import the sheets but I didn't have control over whether they existed or not, "Cover" is mandatory while "Functional" and "Batch" I need at least one of the two to be able to proceed with the next steps.
Now I can check if the "Cover" sheet exists and import it ELSE I exit the Sub, after which I should check if the other sheets also exist and import them but I immediately get the "absent sheet" error.
Below is the code I am getting stuck with:
Sub Import()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim TargetWorkbook As Workbook
Dim SourceWorkbook As Workbook
Dim OpenFileName
Set TargetWorestBookkbook = ActiveWorkbook
'Select and Open Source workbook
OpenFileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*")
If OpenFileName = False Then
MsgBox "Nessun file Source selezionato. Impossibile procedere."
Exit Sub
End If
On Error GoTo exit_
Set SourceWorkbook = Workbooks.Open(OpenFileName)
'Import sheets
' if the sheet doesn't exist an error will occur here
If WorksheetExists("Cover e Legenda") Then
SourceWorkbook.Sheets("Cover e Legenda").Copy _
after:=TargetWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Application.CutCopyMode = False
SourceWorkbook.Close False
Else
MsgBox ("Cover assente. Impossibile proseguire.")
Exit Sub
End If
If WorksheetExists("Test Funzionali") Then
SourceWorkbook.Sheets("Test Funzionali").Copy _
after:=TargetWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Application.CutCopyMode = False
SourceWorkbook.Close False
Else
MsgBox ("Test Funzionali assente.")
End If
If WorksheetExists("Test Batch") Then
SourceWorkbook.Sheets("Test Batch").Copy _
after:=TargetWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Application.CutCopyMode = False
SourceWorkbook.Close False
Else
MsgBox ("Test Batch assente.")
End If
'Next Sheet
Application.ScreenUpdating = True
Application.DisplayAlerts = True
SourceWorkbook.Close SaveChanges:=False
MsgBox ("Importazione completata.")
TargetWorkbook.Activate
exit_:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If Err Then MsgBox Err.Description, vbCritical, "Error"
End Sub
Best to check all of the sheets before importing any of them.
Try something like this:
Sub Import()
Dim wbTarget As Workbook, wbSource As Workbook
Dim OpenFileName, haveCover As Boolean, haveFunz As Boolean, haveTest As Boolean
On Error GoTo haveError
Set wbTarget = ActiveWorkbook
'Select and Open Source workbook
OpenFileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*")
If OpenFileName = False Then
MsgBox "Nessun file Source selezionato. Impossibile procedere."
Exit Sub
End If
Set wbSource = Workbooks.Open(OpenFileName)
'check which sheets exist
haveCover = WorksheetExists(wbSource, "Cover e Legenda")
haveFunz = WorksheetExists(wbSource, "Test Funzionali")
haveTest = WorksheetExists(wbSource, "Test Batch")
If haveCover And (haveFunz Or haveTest) Then 'have the minumum required sheets?
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ImportSheet wbTarget, wbSource.Worksheets("Cover e Legenda")
If haveFunz Then ImportSheet wbTarget, wbSource.Worksheets("Test Funzionali")
If haveTest Then ImportSheet wbTarget, wbSource.Worksheets("Test Batch")
Application.DisplayAlerts = True
Else
MsgBox "Required sheet(s) not found!", vbExclamation
End If
wbSource.Close SaveChanges:=False
MsgBox "Importazione completata"
wbTarget.Activate
Exit Sub 'normal exit
haveError:
MsgBox Err.Description, vbCritical, "Error"
Application.DisplayAlerts = True
End Sub
'copy sheet `ws` to the end of `wbTarget`
Sub ImportSheet(wbTarget As Workbook, ws As Worksheet)
ws.Copy after:=wbTarget.Worksheets(wbTarget.Worksheets.Count)
End Sub
'does sheet `wsName` exist in workbook `wb` ?
Function WorksheetExists(wb As Workbook, wsName As String) As Boolean
On Error Resume Next
WorksheetExists = Not wb.Worksheets(wsName) Is Nothing
On Error GoTo 0
If Not WorksheetExists Then
'log error to errors sheet
With ThisWorkbook.Worksheets("Import Errors").Cells(Rows.Count, "A").End(xlUp)
.Resize(1, 3).Value = Array(Now, wb.Name, "Sheet '" & wsName & "' not found")
End With
End If
End Function
Import Mandatory and Optional Worksheets
Sub ImportWorksheets()
Dim Mandatory() As Variant: Mandatory = VBA.Array("Cover e Legenda")
Dim Optionally() As Variant ' 'Optional' is a keyword
Optionally = VBA.Array("Test Funzionali", "Test Batch")
Dim twb As Workbook: Set twb = ThisWorkbook ' workbook containing this code
' Select and open the Source workbook.
Dim OpenFilePath As Variant
OpenFilePath = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*")
If OpenFilePath = False Then
MsgBox "Nessun file Source selezionato. Impossibile procedere.", _
vbExclamation
Exit Sub
End If
Dim swb As Workbook: Set swb = Workbooks.Open(OpenFilePath)
' Check if all the mandatory worksheets exist.
Dim sws As Worksheet, n As Long
For n = 0 To UBound(Mandatory)
On Error Resume Next ' prevent error if worksheet doesn't exist
Set sws = swb.Worksheets(Mandatory(n))
On Error GoTo 0
If sws Is Nothing Then
'swb.Close SaveChanges:=False
MsgBox "The mandatory worksheet """ & Mandatory(n) _
& """ was not found in """ & swb.Name & """.", vbCritical
Exit Sub
Else
Set sws = Nothing
End If
Next n
' Check if at least one of the optional worksheets exists.
Dim oDict As Object: Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare
For n = 0 To UBound(Optionally)
On Error Resume Next ' prevent error if worksheet doesn't exist
Set sws = swb.Worksheets(Optionally(n))
On Error GoTo 0
If Not sws Is Nothing Then oDict(sws.Name) = Empty: Set sws = Nothing
Next n
If oDict.Count = 0 Then
'swb.Close SaveChanges:=False
MsgBox "No optional worksheets found in """ & swb.Name & """.", _
vbCritical
Exit Sub
End If
' Import the worksheets and close the Source workbook.
Application.ScreenUpdating = False
For n = 0 To UBound(Mandatory)
swb.Sheets(Mandatory(n)).Copy After:=twb.Sheets(twb.Sheets.Count)
Next n
Dim oKey As Variant
For Each oKey In oDict.Keys
swb.Sheets(oKey).Copy After:=twb.Sheets(twb.Sheets.Count)
Next oKey
swb.Close SaveChanges:=False
Application.ScreenUpdating = True
' Inform.
MsgBox "Imported Worksheets" & vbLf & vbLf _
& "Mandatory:" & vbLf & Join(Mandatory, vbLf) & vbLf & vbLf _
& "Optionally:" & vbLf & Join(oDict.Keys, vbLf), vbInformation
End Sub
The parts not working are especially loop parts (marked as --- not working ---). Do I have to “activate” them first somehow?
The part which displays sheet “X” and freezing the screen isn't working too.
I want to display a picture on sheet “X” with a coffee image and the message: “please wait” until the macro is finished.
I tried to avoid the “Select” and “Activate” commands.
'Variables
Dim Destbook As Workbook
Dim Sourcebook As Workbook
Dim DestCell As Range
Dim xFile As String
Dim xFolder As String
Dim xFiles As New Collection
Dim xSheets As Worksheet
Dim xCount As Long
Dim xSheetCount As Long
Dim xRow As Long
Dim A As Integer
Dim I As Integer
Dim Z As Integer
Dim xMax As Double
'On a System Error go to "Troubleshooting" and display the ocurred fault code
On Error GoTo Troubleshooting
'Deactivate Alerts
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.UseSystemSeparators = False
'Display hidden Sheet "X", select cell "A1" and freeze screen
' ------------------------- NOT WORKING ---------------------
ActiveWorkbook.Sheets("X").Visible = xlSheetVisible
With ActiveWorkbook.Sheets("X")
Application.Goto .Range("A1")
ActiveWindow.FreezePanes = True
End With
'Deactivate Alerts
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.UseSystemSeparators = False
'Delete contents for each Sheet containing the name "Data" for the selected range
' ------------------------- NOT WORKING ---------------------
xSheetCount = ActiveWorkbook.Worksheets.Count
For Z = 1 To xSheetCount '
If Left(xSheets.Name, 4) = "Data" Then
With ActiveSheet
.Range("B5:K90000").ClearContents
End With
End If
Next Z
'Select the folder with the desired data to import
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.ButtonName = "Import Data"
.InitialView = msoFileDialogViewList
If .Show = -1 Then xFolder = .SelectedItems(1)
If Right(xFolder, 1) <> "\" Then xFolder = xFolder & "\"
End With
'On error or no files found display the following
If xFolder = "" Then
MsgBox ("No files found or selected!")
Exit Sub
End If
'Get the desired Textfiles in the selected Folder
Set FS = CreateObject("Scripting.FileSystemObject")
Set Folder = FS.Getfolder(xFolder)
For Each File In Folder.Files
If File.Name Like "*####-##-##*" Then
xFile = File.Name
If xFile <> "" Then
xCount = xCount + 1
xFiles.Add xFile, xFile
If xFile = "" Then Resume Next
End If
End If
Next
'File processing
I = 1
Set Destbook = ThisWorkbook
If xFiles.Count > 0 Then
For A = 1 To xFiles.Count
Set Sourcebook = Workbooks.Open(xFolder & xFiles.Item(A), local:=True)
'Skip files with no current values greater than 2 A
xMax = Application.WorksheetFunction.Max(Range("C2:C90000"))
If xMax < 2 Then
GoTo ContinueLoop
End If
If InStr(1, ActiveSheet.Name, "Stufe", vbTextCompare) <> 0 Then
Columns("I:Y").Delete
Rows(1).Insert
Range("D1").Value = ActiveSheet.Name
xRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("A1:J" & xRow).Copy
End If
ThisWorkbook.Sheets("Data (" + CStr(I) + ")").Range("B3").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
On Error Resume Next
On Error GoTo 0
I = I + 1
ContinueLoop: Sourcebook.Close False
Next
End If
'Just some formatting things...
' ------------------------- NOT WORKING ---------------------
xSheetCount = ActiveWorkbook.Worksheets.Count
For I = 1 To xSheetCount
If Left(Worksheet.Name, 4) = "Data" Then
With ActiveSheet.Range("A1:J" & xRow)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
Range("B3:C3").Merge
Range("B3").Value = "Filename:"
Range("B3:K4").Font.Bold = True
Range("B4:K4").Borders.LineStyle = xlContinuous
End With
End If
Next I
'Delete sheet "Import data", hide sheet "X" and save file
'Sheets("Import data").Delete
ActiveWorkbook.Sheets("X").Visible = xlSheetVeryHidden
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Application.UseSystemSeparators = True
'DestBook.SaveAs Filename:=CStr(Date) + "Analysis", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'Display the occured error message and exit program
Troubleshooting: Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Troubleshooting: " & _
Err.Number & vbLf & Err.Description: Err.Clear
Exit Sub
You should add some details about your data and/or your intention.
Using subprocedures could simplify your debugging task.
Avoid "On Error Goto xxx" during development as you need the error details while debugging.
Using "Option Explicit" as a first line simplifies your debugging.
I hope this helps a little! ;-)
Option Explicit
Sub ActivateAlerts_ShowSheetX()
'Activate Alerts
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.UseSystemSeparators = True
ActiveWorkbook.Sheets("X").Visible = xlSheetVisible
End Sub
Sub main()
'Variables
Dim Destbook As Workbook
Dim Sourcebook As Workbook
Dim DestCell As Range
Dim xFile As String
Dim xFolder As String
Dim xFiles As New Collection
Dim xSheets As Worksheet
Dim xCount As Long
Dim xSheetCount As Long
Dim xRow As Long
Dim aCt As Integer
Dim iCt As Integer
Dim zCt As Integer
Dim xMax As Double
'On a System Error go to "Troubleshooting" and
'display the ocurred fault code
'On Error GoTo Troubleshooting
'You want to show Sheet("X") first and then
'Deactivate ScreenUpdating
' 'Deactivate Alerts
' Application.DisplayAlerts = False
' Application.ScreenUpdating = False
' Application.UseSystemSeparators = False
'Display hidden Sheet "X", select cell "A1" and freeze screen
' ------------------------- NOT WORKING ---------------------
ActiveWorkbook.Sheets("X").Visible = xlSheetVisible
With ActiveWorkbook.Sheets("X")
Application.Goto .Range("A1")
ActiveWindow.FreezePanes = True
End With
'Deactivate Alerts
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.UseSystemSeparators = False
'Delete contents for each Sheet containing the name "Data"
'for the selected range
' ------------------------- NOT WORKING ---------------------
xSheetCount = ActiveWorkbook.Worksheets.Count
For zCt = 1 To xSheetCount '
If Left(Sheets(zCt).Name, 4) = "Data" Then
With ActiveSheet
.Range("B5:K90000").ClearContents
End With
End If
Next zCt
'Select the folder with the desired data to import
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.ButtonName = "Import Data"
.InitialView = msoFileDialogViewList
If .Show = -1 Then xFolder = .SelectedItems(1)
If Right(xFolder, 1) <> "\" Then xFolder = xFolder & "\"
End With
'On error or no files found display the following
If xFolder = "" Then
MsgBox ("No files found or selected!")
Exit Sub
End If
Dim FS As Object
Dim Folder As Object
Dim myFile As Object
'Get the desired Textfiles in the selected Folder
Set FS = CreateObject("Scripting.FileSystemObject")
Set Folder = FS.Getfolder(xFolder)
For Each myFile In Folder.Files
If myFile.Name Like "*####-##-##*" Then
MsgBox (myFile.Name & " found!")
xFile = myFile.Name
If xFile <> "" Then
xCount = xCount + 1
xFiles.Add xFile, xFile
If xFile = "" Then Resume Next
End If
End If
Next myFile
'File processing
iCt = 1
Set Destbook = ThisWorkbook
MsgBox "xFiles count: " & xFiles.Count
If xFiles.Count > 0 Then
For aCt = 1 To xFiles.Count
Set Sourcebook = Workbooks.Open(xFolder & xFiles.Item(aCt), local:=True)
'Skip files with no current values greater than 2 A
xMax = Application.WorksheetFunction.Max(Range("C2:C90000"))
If xMax < 2 Then
GoTo ContinueLoop
End If
If InStr(1, ActiveSheet.Name, "Stufe", vbTextCompare) <> 0 Then
Columns("I:Y").Delete
Rows(1).Insert
Range("D1").Value = ActiveSheet.Name
xRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("A1:J" & xRow).Copy
End If
ThisWorkbook.Sheets("Data (" + CStr(iCt) +")").Range("B3").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
On Error Resume Next
On Error GoTo 0
iCt = iCt + 1
ContinueLoop:
Sourcebook.Close False
Next aCt
End If
'Just some formatting things...
' ------------------------- NOT WORKING ---------------------
xSheetCount = ActiveWorkbook.Worksheets.Count
For iCt = 1 To xSheetCount
If Left(Worksheets(iCt).Name, 4) = "Data" Then
With ActiveSheet.Range("A1:J" & xRow)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
Range("B3:C3").Merge
Range("B3").Value = "Filename:"
Range("B3:K4").Font.Bold = True
Range("B4:K4").Borders.LineStyle = xlContinuous
End With
End If
Next iCt
'Delete sheet "Import data", hide sheet "X" and save file
'Sheets("Import data").Delete
ActiveWorkbook.Sheets("X").Visible = xlSheetVeryHidden
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Application.UseSystemSeparators = True
'DestBook.SaveAs Filename:=CStr(Date) + "Analysis", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'Display the occured error message and exit program
Troubleshooting:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Troubleshooting: " & _
Err.Number & vbLf & Err.Description: Err.Clear
Exit Sub
End Sub
I have a template file and 4 source documents that I use to fill the template. For each row in sheet2, I create a new blank template and fill it out, resulting in somewhere between 10-100 files. I want to save these in a loop, but having issues with Excel force closing on me. This is my code so far, recycled from a different project.
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
Dim folderName As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
folderName = Format(Date, "ddmmyyyy")
'set path to save
'fp = "<PATH HERE>" & folderName
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\ThisProject\csvOutput\" & folderName
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder (fp)
End If
'cycle through each of the worksheets
For w = 6 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add after:=Sheets(Sheets.Count)
Range("A1").Select
ActiveSheet.Paste
Worksheets(1).Delete
Worksheets(1).Name = fn
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub ```
The code below worked for me: not sure exactly where the problem might vbe with your posted code, but within your With blocks not everything is scope to the block using a leading .
Sub Test()
Dim w As Long, wb As Workbook, wbNew As Workbook
Dim fp As String, fn As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
Set wb = ThisWorkbook
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\" & _
"ThisProject\csvOutput\" & Format(Date, "ddmmyyyy") & "\"
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder fp
End If
'cycle through each of the worksheets
For w = 6 To wb.Worksheets.Count
'explicitly create a new single-sheet workbook as the destination
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet)
wb.Worksheets(w).Copy before:=wbNew.Sheets(1)
DeleteSheet wbNew.Sheets(2)
With wbNew
fn = .Worksheets(1).Name
.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
.Worksheets(1).Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Worksheets(2).Range("A1")
DeleteSheet .Worksheets(1)
.Worksheets(1).Name = fn
.SaveAs Filename:=fp & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
Next w
Exit Sub
bm_Safe_Exit:
MsgBox Err.Description
End Sub
'utility sub
Sub DeleteSheet(ws As Worksheet)
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
I'm new in Excel-VBA and I need to improve my macro performance. I have a macro that searches an excel, opens it, then goes through every sheet and copy-pastevalues for all cell with a specific color (yellow). Finally saves and closes the excel. In addition, excels sheets are locked and only those yellow cells are editable. This should be done for a list of excel that I indicate in a main template from where I call the macro. The problem is that it takes a lot of time and even gets blocked when the number of excels is more than 3.
I paste my code below and hope anyone can help. Thanks!
Sub Button1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim filePath As String
Dim rng As Range
Dim cel As Range
Dim cartera As String
Dim plantilla As String
Dim wb As Workbook
Dim ws As Worksheet
Dim obj_Cell As Range
filePath = Application.ThisWorkbook.Path
Range("B9").Select
Set rng = Application.Range(Selection, Selection.End(xlDown))
For Each cel In rng.Cells
cartera = cel.Value
plantilla = cel.Offset(0, 1).Value
If cartera = vbNullString Or plantilla = vbNullString Then
GoTo Saltar
End If
Application.StatusBar = "Ejecutando Cartera: " & cartera & ", Plantilla: " & plantilla
Set wb = Workbooks.Open(filePath & "\" & cartera & "\" & plantilla, UpdateLinks:=3)
For Each ws In wb.Worksheets
If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
Worksheets(ws.Name).Activate
For Each obj_Cell In Range("A1:DW105")
With obj_Cell
If obj_Cell.Interior.Color = RGB(255, 255, 153) Then
obj_Cell.Select
If obj_Cell.MergeCells = True Then
obj_Cell.MergeArea.Select
End If
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
If obj_Cell.MergeCells = True Then
If obj_Cell.MergeArea(1).Value = vbNullString Then
obj_Cell.MergeArea.Cells(1, 1).Select
Selection.ClearContents
End If
Else
If obj_Cell.Value = vbNullString Then
obj_Cell.ClearContents
End If
End If
End If
End With
Next obj_Cell
Range("A1").Select
End If
Next ws
Sheets(1).Select
wb.Close SaveChanges:=True
Saltar:
Next cel
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub
Untested- just some "start" ideas for you to use (e.g. no selections, using arrays, fix With statement, no GoTo). I don't understand the logic behind clearing vbNullstring. If it is necessary adapt the code in your way.
I would also suggest opening files with displayalerts on because of few potential problems (e.g. "serious error occur last time file was opened" would hangs your macro)
Sub Button1_Click()
With Application
.ScreenUpdating = False
.StatusBar = True
End With
' If possible change this reference
' from active sheet to sheet's name/codename/index
Dim activeWs As Worksheet
Set activeWs = ActiveSheet
Dim filePath As String
filePath = Application.ThisWorkbook.Path
Dim wb As Workbook
Dim ws As Worksheet
Dim obj_Cell As Range
' range definition
' if lastRow not working change to yours xlDown
' if possible End(xlUp) method is more reliable
Dim rng As Range
Dim lastRw As Long
With activeWs
lastRw = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
Set rng = .Range("B9:B" & lastRw)
End With
' read whole ranges at once
' instead of offset it is possible also to read
' cartera and plantilla at the same time to 2Darray
Dim cartera As Variant
cartera = Application.Transpose(rng.Value2)
Dim plantilla As Variant
plantilla = Application.Transpose(rng.Offset(, 1).Value2)
' main loop
Dim i As Long
For i = 1 To UBound(cartera)
If cartera(i) <> vbNullString Or plantilla(i) <> vbNullString Then
Application.StatusBar = "Ejecutando Cartera: " & cartera(i) & ", Plantilla: " & plantilla(i)
Set wb = Workbooks.Open(filePath & "\" & cartera(i) & "\" & plantilla(i), UpdateLinks:=3)
For Each ws In wb.Worksheets
If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
For Each obj_Cell In ws.Range("A1:DW105")
With obj_Cell
If .Interior.Color = RGB(255, 255, 153) Then
.Value2 = .Value2
' I commented this part beacuse it does not make sense for me...
' If .MergeCells Then
' If .MergeArea(1).Value = vbNullString Then _
.MergeArea.Cells(1, 1).ClearContents
' Else
' If .Value = vbNullString Then .ClearContents
' End If
End If
End With
Next obj_Cell
End If
Next ws
' I would place diplayalerts off here because of potential problems
' with opening files
' if problem occurs it can macro hangs
Application.DisplayAlerts = False
wb.Close SaveChanges:=True
Application.DisplayAlerts = True
End If
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Hello and thank you for your time, in the function code below, how do I make it in a way that it will function on any users computer, not just mine.
I know I need to probably use the Environ("USERPROFILE") thing but I don't know how to incorporate it in the code below.
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const F_PATH As String = "C:\Users\mohammad.reza\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(F_PATH) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open("C:\Users\mohammad.reza\Desktop\MyFiles.xls")
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Thank you brad for your answer, however when I use it, it gives the below error:
Try this ...
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Dim sPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPath = Environ("USERPROFILE") & "\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(sPath) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open(sPath)
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function