I have a spreadsheet xlsm "My_workfile1", I would like to Save As this file like "My_final_workfile_1.xlsm".
I would like to hold all data in "My_final_workfile_1" and have the cells C4,C6,C7,C11,C12 in initial file "My_workfile1" empty after closing.
My code is:
Sub logFormState()
Sheets("1 - Feuille de Suivi ").Range("C4") = ""
Sheets("1 - Feuille de Suivi ").Range("C6") = ""
Sheets("1 - Feuille de Suivi ").Range("C7") = ""
Sheets("1 - Feuille de Suivi ").Range("C11") = ""
Sheets("1 - Feuille de Suivi ").Range("C12") = ""
End Sub
Public Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Name = "My_workfile1" Then
Call logFormState
End If
End Sub
But Me.Name function doesn't work. I'm wondering if my code is correct.
Thank you for your help!
Workbook BeforeClose
Workbook.BeforeClose event
Workbook.SaveCopyAs method
The first procedure is here only to help you to get your names right. It will show the names (and the folder path and the file path) in the Immediate window (CTRL+G).
The Code
Option Explicit
Sub DebugPrint()
With ThisWorkbook
Debug.Print "Workbook:"
Debug.Print """" & .FullName & """"
Debug.Print """" & .Path & """"
Debug.Print """" & .Name & """"
Debug.Print "Worksheet Names:"
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Debug.Print """" & ws.Name & """"
Next ws
End With
End Sub
Sub logFormState()
' Note that this worksheet name ends with a space!
With ThisWorkbook.Worksheets("1 - Feuille de Suivi ")
.Range("C4,C6,C7,C11,C12") = ""
' Either save here...
.Parent.Save
End With
End Sub
Public Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Name = "My_workfile_1.xlsm" Then
' Change the path if necessary.
Me.SaveCopyAs Me.Path & "\" & "My_final_workfile_1.xlsm"
Call logFormState
'... or save here:
'.Save
End If
End Sub
Related
First I selected "Yes" to the question "Change Worksheet Name?". Then the message "Type new Worksheet Name" appears. Instead of typing in a new name and selecting "OK", I select the "cancel" button and my error messages are displayed. How do I avoid seeing the error messages and just let the macro end "quietly"?
Option Explicit ' Force explicit variable declaration.
Sub ChangeSheetName()
Dim Carryon As String
On Error GoTo eh
Carryon = MsgBox("Change Worksheet Name?", vbYesNo)
If Carryon = vbYes Then
Dim shName As String
Dim currentName As String
currentName = ActiveSheet.Name
shName = InputBox("Type new Worksheet name")
ThisWorkbook.Sheets(currentName).Name = shName
End If
Exit Sub
eh:
MsgBox "The following error occured." _
& vbCrLf & "" _
& vbCrLf & "Error Number is: " & Err.Number _
& vbCrLf & "" _
& vbCrLf & "Error Description is: " & Err.Description _
& vbCrLf & "" _
& vbCrLf & "You likely hit the Esc key to stop renaming the Worksheet." _
& vbCrLf & "" _
& vbCrLf & "No worries. You can try again to rename or leave it as is." _
& vbCrLf & "" _
& vbCrLf & "No harm done."
End Sub
You've declared Carryon as a string variable - vbYes (and other messagebox results) are numeric constants.
Change Dim Carryon As String to Dim Carryon As Long
If the user presses "Cancel", the InputBox-Function returns an empty string (""). If you try to use that empty string as a worksheet name, you will get an runtime error (as this is not a valid sheet name) and your error handler is triggered.
To avoid this, simply check if shName is not the empty string before assigning the name.
If MsgBox("Change Worksheet Name?", vbYesNo) <> vbYes Then Exit Sub
Dim currentSheet As Worksheet, shName As String
Set currentSheet = ActiveSheet
shName = InputBox("Type new Worksheet name")
If shName <> "" Then
currentSheet.Name = shName
End If
You can use StrPtr to handle InputBoxes. This is an undocumented function that is used to get the underlying memory address of variable.
Here is an example
shName = InputBox("Type new Worksheet name")
If (StrPtr(shName) = 0) Or (shName = "") Or Len(Trim(shName)) = 0 Then
'~~> StrPtr(shName) = 0 : User Pressed Cancel, or the X button
'~~> shName = "" : User tried to pass a blank value
'~~> Len(Trim(shName)) = 0 : User tried to pass space(s)
Exit Sub ' Or do what you want
Else
MsgBox "Worksheet Name: " & shName
End If
Please, try the next way:
Sub MsgBoxYesNoHandling()
Dim Carryon As VbMsgBoxResult, shName As String
Carryon = MsgBox("Change Worksheet Name?", vbYesNo)
If Not Carryon = vbYes Then Exit Sub
shName = InputBox("Type new Worksheet name")
If Len(Trim(shName)) = 0 Then Exit Sub
'do here whatever you need..
End Sub
Rename Sheet
This will rename any active sheet (worksheet or chart), not just if it's the active sheet in the workbook containing this code (ThisWorkbook). Before exiting, it will show a message box only if it was successful.
Sub RenameSheet()
Const PROC_TITLE As String = "Rename Sheet"
On Error GoTo ClearError ' start main error-handling routine
Dim sh As Object: Set sh = ActiveSheet
If sh Is Nothing Then
MsgBox "No visible workbooks open.", vbExclamation, PROC_TITLE
Exit Sub
End If
Dim OldName As String: OldName = sh.Name
Dim NewName As String, MsgNumber As Long
Do
NewName = InputBox("Input the new sheet name:", PROC_TITLE, OldName)
If Len(NewName) = 0 Then Exit Sub
On Error GoTo RenameError ' start Rename error-handling routine
sh.Name = NewName
On Error GoTo ClearError ' restart main error-handling routine
Select Case MsgNumber
Case 0, vbNo: Exit Do
Case vbYes: MsgNumber = 0 ' reset for the next iteration
End Select
Loop
If MsgNumber = 0 Then
If StrComp(OldName, NewName, vbBinaryCompare) = 0 Then Exit Sub
MsgBox "Sheet renamed from '" & OldName & "' to '" & NewName & "'.", _
vbInformation, PROC_TITLE
End If
ProcExit:
Exit Sub
RenameError: ' continue Rename error-handling routine
MsgNumber = MsgBox("Could not rename from '" & OldName & "' to '" _
& NewName & "'. Try again?" & vbLf & vbLf & "Run-time error '" _
& Err.Number & "':" & vbLf & vbLf & Err.Description, _
vbYesNo + vbQuestion, PROC_TITLE)
Resume Next
ClearError: ' continue main error-handling routine
MsgBox "An unexpected error occurred." _
& vbLf & vbLf & "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
& Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Sub
Thank you all for your answers.
I ended up just removing the error handling code and adding an extra If statement.
Sub ChangeSheetName()
Dim Carryon As String
Carryon = MsgBox("Change Worksheet Name?", vbYesNo)
If Carryon = vbYes Then
Dim shName As String
Dim currentName As String
currentName = ActiveSheet.Name
shName = InputBox("Type new Worksheet name")
If shName <> "" Then
ThisWorkbook.Sheets(currentName).Name = shName
End If
End If
End Sub
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.
I have this chunk of code :
The macro that calls 2 other macros depending on the cell value is this :
Option Explicit
Function lastRow(col As Variant, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
Sub runMacros()
Dim vDat As Variant
Dim i As Long
Dim wks As Worksheet
Set wks = ActiveSheet
With wks
vDat = .Range(.Cells(1, "G"), .Cells(lastRow("G"), "G"))
End With
For i = LBound(vDat) To UBound(vDat)
If vDat(i, 1) = "First" Then
Macro3
Macro1
ElseIf vDat(i, 1) = "Second" Then
Macro3
Macro2
End If
Next i
End Sub
The first macro that is being called is this(Macro3) - it just creates a new folder if it does not exist:
Sub Macro3()
Dim Path As String
Dim Folder As String
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
End If
End Sub
and then I have this macro:
Sub Macro1()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, SavePath As String, StrFileName As String, MailSubjectName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
SavePath = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" 'Name of the folder
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "RejectionLetterEmployee.docx" 'Name of the word file
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Rejection$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name") 'File name will be determined by this column name
MailSubjectName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
StrFileName = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" & StrName
With wdApp.ActiveDocument
'.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False 'Save as WORD file(not needed at the moment)
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder where the excel sheet exists(not needed)
.SaveAs Filename:=SavePath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder that has been created by Path_Exists function
.Close SaveChanges:=False
' Set OutApp = CreateObject("Outlook.Application")
' Set OutMail = OutApp.CreateItem(0)
' On Error Resume Next
' With OutMail
' .To = ""
' .SentOnBehalfOfName = ""
' .CC = ""
' .BCC = ""
' .Subject = "ID" & " " & MailSubjectName & " " & StrName
' .BoDy = ""
' .Attachments.Add StrFileName & ".pdf"
' .Display
'.Send
' End With
' On Error GoTo 0
' Set OutMail = Nothing
' Set OutApp = Nothing
End With
' Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Macro1 and Macro2 are the same code but they use a different Word file to create the PDF - Macro1 runs if a cell in "G" column contains the string "first" and Macro2 runs if it contains "second".
The macros create a PDF file and sends it via Outlook.
The problem with Macro1 and Macro2 is that they have a For loop which runs through all rows which basically contradicts what I want to do based on a cell value.
I tried to tweak it a little but since im not familiar that much with VBA I couldnt make it run on the row based on the For loop that runMacros() executes when it calls the 2 other macros.
I only succeeded making it work only on the first row or the last row.
So my question is this : How would I fix Macro1 code to work on a row that runMacros() check.
For example : runMacros() is executed via button.
it checks if G2 cell contains either "first" or "second".
if it contains "first" it will run Macro3 and Macro1.
if it contains "second" it will run Macro3 and Macro2.
runMacros() will then go to the next row, check and execute the macros until it reaches an empty row.
currently Macro1 and Macro2 have a for loop which is wrong because if the G2 contains "first" and G3 contains "second" all the PDF files will be according to Macro2 because it just replaced what Macro1 did
I want Macro1 and Macro2 to follow the row that runMacros() is checking and only execute on that row.
How do I do that?
In answering your question in passing parameters, there are a couple ways to do this. In the first example, create your vDat variable as a Range, then loop over the range and pass a range parameter.
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Range
With wks
Set vDat = .Range("G1").Resize(lastRow("G"), 1)
End With
Dim i As Long
For i = 1 To vDat.Rows.Count
If vDat.Offset(i, 0).Value = "First" Then
Macro3 vDat.Rows(i)
Macro1 vDat.Rows(i)
ElseIf vDat.Offset(i, 0).Value = "Second" Then
Macro3 vDat.Rows(i)
Macro2 vDat.Rows(i)
End If
Next i
End Sub
Private Sub Macro1(ByRef theRow As Range)
Debug.Print "Macro1 row address = " & theRow.Address
End Sub
Private Sub Macro2(ByRef theRow As Range)
Debug.Print "Macro2 row address = " & theRow.Address
End Sub
Private Sub Macro3(ByRef theRow As Range)
Debug.Print "Macro3 row address = " & theRow.Address
End Sub
But you actually created vDat as an array, so you can just pass the value of that row in the array:
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Variant
With wks
vDat = .Range("G1").Resize(lastRow("G"), 1).Value
End With
Dim i As Long
For i = LBound(vDat, 1) To UBound(vDat, 1)
If vDat(i, 0) = "First" Then
Macro3 vDat(i, 0)
Macro1 vDat(i, 0)
ElseIf vDat(i, 0) = "Second" Then
Macro3 vDat(i, 0)
Macro2 vDat(i, 0)
End If
Next i
End Sub
Private Sub Macro1(ByVal theRowValue As Variant)
Debug.Print "Macro1 row value = " & theRowValue
End Sub
Private Sub Macro2(ByVal theRowValue As Variant)
Debug.Print "Macro2 row value = " & theRowValue
End Sub
Private Sub Macro3(ByVal theRowValue As Variant)
Debug.Print "Macro3 row value = " & theRowValue
End Sub
What is not clear in your code and question is how the row relates to the DataSource or how you are using it in Macro1 or Macro2. I would also suggest renaming your macros to something more descriptive to what action the macro is performing.
With MailMerge you can create a batch of documents from a datasource.
Using the Status column as a WHERE clause in the datasource SQL allows you to create the
documents with only 2 runs of the same subroutine using a parameter to apply the different template.
Option Explicit
Sub runMacros()
Dim Template1 As String, Template2 As String, Path As String, Folder As String
Template1 = ThisWorkbook.Path & "RejectionLetterEmployee.docx"
Template2 = ThisWorkbook.Path & "RejectionLetterEntrepreneur.docx"
' create path for documents
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir Path
End If
' create documents
CreateDocuments "First", Template1, Path
CreateDocuments "Second", Template2, Path
MsgBox "Ended"
End sub
Sub CreateDocuments(Status As String, Template As String, SavePath)
MsgBox "Running macro for Status = [" & Status & "] using " & Template & vbCrLf & _
" into Folder " & SavePath, vbInformation
Const StrNoChr As String = """*./\:?|"
' Paths and Filename
Dim strMMSrc As String, strMMDoc As String, strMMPath As String
Dim StrFileName As String, t0 As Single
t0 = Timer
' open template
Dim wdApp As New Word.Application, wdDoc As Word.Document, i As Integer, j As Integer
Dim strName, MailSubjectName
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
Set wdDoc = wdApp.Documents.Open( _
Filename:=Template, _
AddToRecentFiles:=False, _
ReadOnly:=True, _
Visible:=False)
strMMSrc = ThisWorkbook.FullName ' datasource name
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.OpenDataSource Name:=strMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=strMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=" SELECT * FROM `Rejection$` WHERE Status = '" & Status & "'"
' confirm to create docs
If vbNo = MsgBox(.DataSource.RecordCount & " documents will be created in " & SavePath & _
", continue ?", vbYesNo, "Confirm") Then
GoTo skip
End If
' create one doc for each record in datasource
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
strName = Trim(.DataFields("Name"))
MailSubjectName = Trim(.DataFields("ID"))
'Debug.Print "Raw", i, strName, MailSubjectName
If strName = "" Then Exit For
End With
' do merge
.Execute Pause:=False
' construct doc filename to save
' replace illegal characters
For j = 1 To Len(StrNoChr)
strName = Replace(strName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
Debug.Print "Cleaned ", i, strName, MailSubjectName
'Save to the folder that has been created by Path_Exists function
StrFileName = SavePath & strName
With wdApp.ActiveDocument
.SaveAs Filename:=SavePath & strName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
MsgBox i - 1 & " documents created in " & SavePath, vbInformation, "Completed in " & Int(Timer - t0) & " secs"
skip:
' cleanup
wdDoc.Close SaveChanges:=False
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
I am trying to delete empty rows in every sheet using this code in Excel 2010:
Private Sub CommandButton1_Click()
Dim I As Integer
'For all sheets...
For I = 1 To Sheets.Count
'select corresponding sheet
Sheets(I).Select
Sheets(I).Activate
'write delete code
For fila = 1 To 10
If Cells(fila, 4).Value = "" Then
Rows(fila).Delete
End If
Next fila
'Go to next sheet
Next
End Sub
This code only deletes rows on my first active sheet.
Always remember to loop backward when deleting objects (in your case rows), so use For i = 10 to 1 Step -1.
Also, try to avoid using Select and Activate, instead you could directly reference the Worksheet or Range. In this case use directly the ws defined as Worksheet, to see if If ws.Cells(fila, 4).Value = ""
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim I As Integer, fila As Long
Dim ws As Worksheet
' loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
' loop backwards when deleting objects
For fila = 10 To 1 Step -1
If ws.Cells(fila, 4).Value = "" Then ws.Rows(fila).Delete
Next fila
Next ws
End Sub
Maybe this solution will help you :
It will clean all worksheets in your workbook and delete empty rows.
In the end, msg box will tell you the percentage of rows that were deleted for each sheet.
Best regards,
Sub Clean()
Dim Sht As Worksheet, DCell As Range, Calc As Long, Rien As String, Avant As Double, plage As Range
On Error Resume Next
Calc = Application.Calculation ' ---- mémorisation de l'état de
recalcul
'------------------------------------------------------------
MsgBox "Pour le classeur actif : " _
& Chr(10) & ActiveWorkbook.FullName _
& Chr(10) & "dans chaque feuille de calcul" _
& Chr(10) & "recherche la zone contenant des données," _
& Chr(10) & "réinitialise la dernière cellule utilisée" _
& Chr(10) & "et optimise la taille du fichier Excel", _
vbInformation, _
"d'après LL par GeeDee#m6net.fr"
'-------------------------------------------------------------
MsgBox "Taille initiale de ce classeur en octets" _
& Chr(10) & FileLen(ActiveWorkbook.FullName), _
vbInformation, ActiveWorkbook.FullName
'------------------------------------------------------------
With Application
.Calculation = xlCalculationManual
.StatusBar = "Nettoyage en cours..."
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = True
End With
'-------------------- le traitement
For Each Sht In Worksheets
Avant = Sht.UsedRange.Cells.Count
Application.StatusBar = Sht.Name & "-" & Sht.UsedRange.Address
'-------------------Traitement de la zone trouvée
If Sht.UsedRange.Address <> "$A$1" Or Not IsEmpty(Sht.[A1]) Then
Set DCell = Sht.Cells.Find("*", , , , xlByRows, xlPrevious)(2)
'----------------Suppression des lignes inutilisées
If Not DCell Is Nothing Then
Sht.Range(DCell, Sht.Cells([A:A].Count, 1)).EntireRow.Delete
Set DCell = Nothing
Set DCell = Sht.Cells.Find("*", , , , xlByColumns, xlPrevious)(, 2)
'----------------Suppression des colonnes inutilisées
If Not DCell Is Nothing Then Sht.Range(DCell, Sht.[IV1]).EntireColumn.Delete
End If
Rien = Sht.UsedRange.Address
End If
ActiveWorkbook.Save
'---------------------Message pour la feuille traitée
MsgBox "Nom de la feuille de calcul :" _
& Chr(10) & Sht.Name _
& Chr(10) & Format(Sht.UsedRange.Cells.Count / Avant, "0.00%") & " de la taille initiale", _
vbInformation, ActiveWorkbook.FullName
Next Sht
'--------------------Message fin de traitement
MsgBox "Taille optimisée de ce classeur en octets " & Chr(10) & FileLen(ActiveWorkbook.FullName), _
vbInformation, _
ActiveWorkbook.FullNameActive
'--------------------
Application.StatusBar = False
Application.Calculation = Calc
End Sub
I'm trying to create a macro for a command button that when clicked, will get the job number from that row and look for a file for that job. If it does not exist I want it to copy from a template and save with a new name, otherwise just open the file.
However, I cannot seem to work out how to get hold of the information for the command button that calls the macro. This is what I have so far:
Public Function ShapeExists(OnSheet As Object, Name As String) As Boolean
On Error GoTo ErrShapeExists
If Not OnSheet.Shapes(Name) Is Nothing Then
ShapeExists = True
End If
ErrShapeExists:
Exit Function
End Function
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim buttonName As String
buttonName = (Target.Row - 1)
If Not ShapeExists(ActiveSheet, buttonName) Then
If Range("O" & Target.Row).Value = "" And Target.Column <= 14 And Target.Row > 1 Then
ActiveSheet.Buttons.Add(910.5, Range("O" & Target.Row).Top, 80, 20).Select
Selection.Name = buttonName
Selection.OnAction = "Sheet1.JobButton"
ActiveSheet.Shapes(buttonName).Select
Selection.Characters.Text = "Open Job"
End If
End If
End Sub
Private Sub JobButton()
Dim newText As String
ActiveSheet.Shapes(Application.Caller).Select
If Range("N" & Selection.TopLeftCell.Row).Value <> "" Then
newText = "Job " & Range("N" & Selection.TopLeftCell.Row).Value
Dim checkFilename As String
Dim check As String
check = "N" & Selection.TopLeftCell.Row
checkFilename = newText & ".xlsm"
If Dir(checkFilename) <> "" Then
Workbooks.Open (newText)
Else
Dim SrcBook As Workbook
Set SrcBook = ThisWorkbook
Dim NewBook As Workbook
NewBook = Workbooks.Open("Job Template.xlsm")
SrcBook.Worksheets(1).Range("D" & Selection.TopLeftCell.Row).Copy
NewBook.Worksheets(2).Range("B15").PasteSpecial
With NewBook
.Title = newText
.Subject = newText
.SaveAs Filename:=newText
End With
End If
Else
ErrMsg:
MsgBox ("Job Should always have a number."), , "NO JOB NUMBER"
End If
End Sub
As you can see I am currently trying ActiveSheet.Shapes(Application.Caller).Select, this is causing a "Run-time error '13': Type mismatch".
Any help would be much appreciated, thank you!
Right-click the button --> View Code --> put your JobButton code here