I started learning VBA for an internship, 3 months ago. This is the last project I have worked on. It does all the tasks it has to do, it's all about code review. I will be grateful for all suggestions for optimization of solutions/other solutions, good practices (writing, commenting on the code) and everything else that you think may help me in the future.
The workbook is used to automate the sending of an e-mail by the applicant to the classifier (appropriate people in the company who can complete the process), and then for the classifier it automates the filling of a special excel sheet with which further steps are taken. Additionally, this workbook is on a network drive. Target users download it to their local drive and may sometimes need to be updated, hence the "check workbook update" function (this function caused me a lot of problems, I'm curious about other solutions. I'm aware that the current one is not the best). The list of classifiers is also monitored for changes because it also changes regularly
Everywhere in the code where "xyz" is intentional. the program was written in Polish and I actually translate it only for the needs of this post, so I am sorry if somewhere there are remains of Polish and places not the best translations
Code in "Backend" worksheet
Option Explicit
Dim externalFile As Workbook
Dim backend As Worksheet
Const numberOfRowsBeforeRecords = 1
Sub CheckingComplianceClassifierList()
'Checking if the workbook with the list of classifiers has not changed since the last time using this workbook and update this list in this workbook if needed
Module3.OptimizeCodeBegin
Dim lastModifiedExternalFile As Date 'last updated classifier workbook
Dim cellWithModifiedDate As Range
Dim externalFilePath As String
Set backend = ThisWorkbook.Worksheets("Backend")
externalFilePath = backend.Range("B2").Value2
Set externalFile = Module3.OpenAndSetFile(externalFilePath)
If Not externalFile Is Nothing Then 'case when the OpenAndSetFile function does not work (probably, the wrong path)
lastModifiedExternalFile = FileDateTime(externalFilePath)
Set cellWithModifiedDate = backend.Range("B1")
If cellWithModifiedDate.Value2 < lastModifiedExternalFile Then 'last check < modification date
Dim classifiersAmount As Integer
With externalFile.Worksheets(1)
classifiersAmount = .Cells(.Rows.Count, "A").End(xlUp).Row - numberOfRowsBeforeRecords 'checks the amount of classifiers in an external file
End With
PrepareWorksheet classifiersAmount 'Cleaning classifier tables
RewriteClassifiers classifiersAmount
ProcessClose 'removes filters, closes the external file
cellWithModifiedDate.Value2 = Now() 'updates date
Else
externalFile.Close False
End If
End If
Module3.OptimizeCodeEnd
End Sub
Sub PrepareWorksheet(classifiersAmount As Integer)
'clearing the classifier tables - needed if the number in some area decreases
With backend
If .Range("A7") <> "" Then .ListObjects("TabelaMechanical").DataBodyRange.Delete 'if cell A7 (first table cell) is empty, it means that the table is already cleared
If .Range("B7") <> "" Then .ListObjects("TabelaPower").DataBodyRange.Delete
If .Range("C7") <> "" Then .ListObjects("TabelaInteriors").DataBodyRange.Delete
If .Range("D7") <> "" Then .ListObjects("TabelaCSS").DataBodyRange.Delete
End With
End Sub
Sub RewriteClassifiers(classifiersAmount As Integer)
'Sub which takes data from the external spreadsheet and pastes it into it
Dim externalData As Worksheet
Dim namesColumn As Range
Dim lastRow As Integer
lastRow = classifiersAmount + numberOfRowsBeforeRecords
Set externalData = externalFile.Worksheets(1)
Set namesColumn = externalData.Range("C2:C" & lastRow) 'column containing the name of classifiers
FilterAndCopy "Mechanical Systems", externalData, namesColumn, "A7" 'Sub FilterAndCopy(workingArea As String, externalData As Worksheet, namesColumn As Range, destination As String)
FilterAndCopy "Power&Control", externalData, namesColumn, "B7"
FilterAndCopy "Interiors", externalData, namesColumn, "C7"
FilterAndCopy "CSS", externalData, namesColumn, "D7"
End Sub
Sub ProcessClose()
externalFile.Worksheets(1).Cells.AutoFilter
externalFile.Close SaveChanges:=False
End Sub
Sub FilterAndCopy(workingArea As String, externalData As Worksheet, namesColumn As Range, destination As String)
externalData.Cells.AutoFilter Field:=11, Criteria1:=workingArea
namesColumn.SpecialCells(xlCellTypeVisible).Copy 'copies visible cells from the column containing the name of the classifier
backend.Range(destination).PasteSpecial xlPasteValues
End Sub
Sub CheckingComplianceTemplate()
Set backend = ThisWorkbook.Worksheets("Backend")
Dim lastModifiedExternalFile As Date
Dim externalFilePath As String
externalFilePath = backend.Range("E2").Value2
lastModifiedExternalFile = FileDateTime(externalFilePath)
Dim cellWithModifiedDate As Range
Set cellWithModifiedDate = backend.Range("E1")
Dim permissionCell As Range
Set permissionCell = backend.Range("E3")
If cellWithModifiedDate.Value2 < lastModifiedExternalFile Then 'last check < modification date, a positive result means that the template has been modified since the last check
permissionCell.Value2 = False
MsgBox "Your version of the spreadsheet is out of date. Download current template - location: xyz"
Else
permissionCell.Value2 = True
cellWithModifiedDate = Now()
End If
End Sub
Code in "ThisWorkbook"
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Worksheets("backend").CheckingComplianceTemplate
If ThisWorkbook.Worksheets("backend").Range("E3").Value2 = True Then
ThisWorkbook.Worksheets("backend").Range("E1").Value2 = DateAdd("s", 10, Now())
End If
Module3.OptimizeCodeEnd
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ThisWorkbook.Worksheets("backend").CheckingComplianceTemplate
If ThisWorkbook.Worksheets("backend").Range("E3").Value2 = True Then
ThisWorkbook.Worksheets("backend").Range("E1").Value2 = DateAdd("s", 10, Now())
End If
End Sub
Private Sub Workbook_Open()
With ThisWorkbook
.Worksheets(2).Protect UserInterfaceOnly:=True, Password:="xyz"
.Worksheets(3).Protect UserInterfaceOnly:=True, Password:="xyz"
End With
Arkusz4.CheckingComplianceClassifierList
Arkusz4.CheckingComplianceTemplate
End Sub
Code in "Module2" module
Option Explicit
Dim batchLoad As Workbook
Dim classifications As Worksheet, backend As Worksheet
Dim recordAmount As Integer
Const numberRowsBeforeRecordsClassificationWorksheet = 8
Sub BatchLoadFillingProcess()
ThisWorkbook.Worksheets("backend").CheckingComplianceTemplate
If ThisWorkbook.Worksheets("backend").Range("E3") = True Then 'cell E3 stores the value true / false set on the basis of checking compliance with the template on a network drive
Module3.OptimizeCodeBegin
PrepareWorksheet 'assign/calculate global variables/objects
If CheckSignature = True Then 'compares the saved signature with what it should be
If Verification = True Then 'Verification whether all started rows have all columns filled in and whether part of the classifier is filled in correctly
FillingBatchLoad
SaveBatchLoad
Else
batchLoad.Close SaveChanges:=False 'close BatchLoada's template
End If
Module3.OptimizeCodeEnd
Else
batchLoad.Close SaveChanges:=False 'close BatchLoada's template
End If
End If
End Sub
Sub PrepareWorksheet()
Set classifications = ThisWorkbook.Worksheets("Classification")
Set backend = ThisWorkbook.Worksheets("backend")
Dim templatePath As String
templatePath = backend.Range("H1")
Workbooks.Open Filename:=templatePath, ReadOnly:=True
Set batchLoad = ActiveWorkbook
Dim recordRange As Range
Set recordRange = ThisWorkbook.Worksheets(1).Range("B9:B59")
recordAmount = Application.WorksheetFunction.CountA(recordRange)
End Sub
Function CheckSignature() As Boolean
Dim currentSignature As String, project As String, classifier As String, correctSignature As String
currentSignature = backend.Range("B5").Value2
project = classifications.Range("F3").Value2
classifier = classifications.Range("F5").Value2
classifier = Replace(classifier, " ", "")
correctSignature = project & classifier & recordAmount
If correctSignature = currentSignature Then
CheckSignature = True
Else
CheckSignature = False
MsgBox "Wrong Signature"
End If
End Function
Function Verification() As Boolean
Dim recordAmount As Integer
Verification = VerificationRowFilling 'function checks if columns B to H are filled in every started row
If Verification = True Then
Verification = ClassifierRowVerification 'function checks if the classifier did not fill rows that the applicant did not fill
End If
End Function
Function VerificationRowFilling() As Boolean
'Define the range of filled rows
Dim rangeFilledRows As Range
Set rangeFilledRows = Range(classifications.Cells(numberRowsBeforeRecordsClassificationWorksheet + 1, 2), classifications.Cells(numberRowsBeforeRecordsClassificationWorksheet + recordAmount, 8))
'The condition checks whether the number of filled cells in the range (left side) corresponds to the number of cells in the range (right side)
'there is no option to fill more cells than it is in range, so else is synonymous with equality
If WorksheetFunction.CountA(rangeFilledRows) < rangeFilledRows.Count Then
VerificationRowFilling = False
MsgBox "Not all columns in the started rows are filled"
Else
VerificationRowFilling = True
End If
End Function
Function ClassifierRowVerification() As Boolean
'define the range that we will check
Dim amountRowsFilledByApplicant As Integer
amountRowsFilledByApplicant = numberRowsBeforeRecordsClassificationWorksheet + recordAmount
Dim rangeOutOfFilledRange As Range
Set rangeOutOfFilledRange = Range(classifications.Cells(amountRowsFilledByApplicant + 1, 2), classifications.Cells(60, 8))
'Note: 60th row is out of table, but if the last row was 59, the condition check below gives an incorrect result if all rows in the table are filled (amountRowsFilledByApplicant + 1 = 59 + 1 = 60)
'checking if there are any filled cells in the unwanted range
Dim amountOfFilledCellsInUnwantedRange As Integer
amountOfFilledCellsInUnwantedRange = Application.WorksheetFunction.CountA(rangeOutOfFilledRange)
'return the appropriate flag, display the message
If amountOfFilledCellsInUnwantedRange = 0 Then 'no filled cells outside the wanted range
ClassifierRowVerification = True
Else
ClassifierRowVerification = False
MsgBox "filling cells outside records filled by the applicant"
End If
End Function
Sub FillingBatchLoad()
'Function that fulfills the BatchLoad template based on the data entered in this spreadsheet
Dim currentSpreadsheetRow As Range, currentBatchLoadRow As Range
Dim loopCounter As Integer
Const naglowekBatchLoada = 1
For loopCounter = 1 To recordAmount
'defining the row from which we take data and to which we save data in a given iteration
With classifications
Set currentSpreadsheetRow = .Range(.Cells(loopCounter + numberRowsBeforeRecordsClassificationWorksheet, 2), .Cells(loopCounter + numberRowsBeforeRecordsClassificationWorksheet, 8))
End With
With batchLoad.Worksheets(1)
Set currentBatchLoadRow = .Range(.Cells(loopCounter + naglowekBatchLoada, 1), .Cells(loopCounter + naglowekBatchLoada, 31))
End With
currentBatchLoadRow(1).Value2 = currentSpreadsheetRow(1).Value2 'xyz
currentBatchLoadRow(2).Value2 = currentSpreadsheetRow(4).Value2 'xyz
currentBatchLoadRow(3).Value2 = currentSpreadsheetRow(2).Value2 'xyz
currentBatchLoadRow(4).Value2 = "?" 'xyz
currentBatchLoadRow(5).Value2 = "?" 'xyz
currentBatchLoadRow(6).Value2 = "?" 'xyz
currentBatchLoadRow(7).Value2 = "?" 'xyz
currentBatchLoadRow(8).Value2 = currentSpreadsheetRow(5).Value2 'xyz
currentBatchLoadRow(13).Value2 = classifications.Range("F3").Value2 'xyz
currentBatchLoadRow(14).Value2 = backend.Range("B4").Value2 'xyz
currentBatchLoadRow(16).Value2 = "?" 'xyz
currentBatchLoadRow(17).Value2 = "?" 'xyz
currentBatchLoadRow(18).Value2 = currentSpreadsheetRow(6).Value2 'xyz
currentBatchLoadRow(20).Value2 = currentSpreadsheetRow(7).Value2 'xyz
currentBatchLoadRow(21).Value2 = "?" 'xyz
currentBatchLoadRow(23).Value2 = backend.Range("B3").Value2 'xyz
currentBatchLoadRow(24).Value2 = "?" 'xyz
currentBatchLoadRow(25).Value2 = classifications.Range("F4").Value2 'xyz
Next loopCounter
End Sub
Sub SaveBatchLoad()
Dim tytul As String
tytul = "BatchLoad for project - " & classifications.Range("F3").Value2 'classifications.Range("F3") it's project's number
batchLoad.Activate
Dim batchLoadPath As String
batchLoadPath = Application.GetSaveAsFilename(InitialFileName:=tytul, FileFilter:="Excel Files (*.xlsb), *.xlsb")
If batchLoadPath <> "False" Then 'batchLoadPath = False means that the user has not selected any location
batchLoad.SaveAs Filename:=batchLoadPath
batchLoad.Close SaveChanges:=False 'close BatchLoad's template
Workbooks.Open Filename:=batchLoadPath
Else
MsgBox "Please enter the path"
batchLoad.Close SaveChanges:=False
End If
End Sub
Code in "Module3" module
Option Explicit
Dim CalcState As Long
Dim EventState As Boolean, PageBreakState As Boolean, DisplayAlertsState As Boolean
Sub OptimizeCodeBegin()
Application.ScreenUpdating = False
'EventState = Application.EnableEvents
'Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
DisplayAlertsState = Application.DisplayAlerts
Application.DisplayAlerts = False
End Sub
Sub OptimizeCodeEnd()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
'Application.EnableEvents = EventState
Application.DisplayAlerts = DisplayAlertsState
Application.ScreenUpdating = True
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
'*****************************
'Insert Your Code Here...
'*****************************
'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
Function OpenAndSetFile(path) As Workbook
If Dir(path) = "" Then 'dir(path) returns the file name, "" means that no file was found
MsgBox "file path not found"
Exit Function
Else
Set OpenAndSetFile = Workbooks.Open(Filename:=path, ReadOnly:=True)
End If
End Function
Sub Cleaning()
Dim orderRange As Range, applicantRange As Range, classifierRange As Range
If MsgBox("Do you want to clear the spreadsheet from the entered data??", vbYesNo, "Cleaning") = vbYes Then
With ThisWorkbook.Worksheets("Classification")
Set orderRange = .Range("F3:F5")
Set applicantRange = .Range("B9:F59")
Set classifierRange = .Range("G9:H59")
End With
orderRange.ClearContents
applicantRange.ClearContents
classifierRange.ClearContents
End If
End Sub
Code in "Module4" module
Option Explicit
Dim amountRecords As Integer
Const numberRowsBeforeRecordsClassificationWorksheet = 8
Sub SendingEmailToClassifier()
ThisWorkbook.Worksheets("backend").CheckingComplianceTemplate
If ThisWorkbook.Worksheets("backend").Range("E3") = True Then 'cell E3 stores the value true / false set on the basis of checking compliance with the template on a network drive
Module3.OptimizeCodeBegin
If Verification = True Then
PrepareWorksheet 'finding classifier and applicant email
SendingEmail 'preparation, content generation and sending an e-mail
Else
ThisWorkbook.Worksheets("Backend").Range("B3:B4").ClearContents
End If
Module3.OptimizeCodeEnd
End If
End Sub
Sub PrepareWorksheet()
ThisWorkbook.Worksheets("Backend").Range("B3").Value2 = ClassiferEmail
ThisWorkbook.Worksheets("Backend").Range("B4").Value2 = ApplicantEmail
End Sub
Function Verification() As Boolean
Dim CollumnInTabel As Range
Set CollumnInTabel = ThisWorkbook.Worksheets("Classification").Range("B9:B59") 'first of the columns inside the table
amountRecords = Application.WorksheetFunction.CountA(CollumnInTabel)
If amountRecords > 0 Then 'A positive result means that at least one record has been entered
Verification = VerificationNoBlankRows 'check if there are no empty lines between the entered records
Else
MsgBox "Enter at least one record"
Exit Function
End If
If Verification = True Then
Verification = VerificationRowFilling 'checking if every started record has columns A-F filled
Else
Exit Function
End If
If Verification = True Then
Verification = VerificationClassifierEmpty() 'checking if the classifier area is empty
Else
Exit Function
End If
If Verification = True Then
Verification = VerificationOrderRange 'checking if order range is filled
Else
Exit Function
End If
End Function
Function VerificationOrderRange() As Boolean
'' Check if the cells F3-F5 are filled and return the appropriate message, if needed
VerificationOrderRange = True
With ThisWorkbook.Worksheets("Classification")
If .Range("F3") = "" Then
MsgBox "Cell F3 (Project number) is empty"
VerificationOrderRange = False
Exit Function
End If
If .Range("F4") = "" Then
MsgBox "Cell F4 (Working area) is empty"
VerificationOrderRange = False
Exit Function
End If
If .Range("F5") = "" Then
MsgBox "Cell F5 (Classifier) is empty"
VerificationOrderRange = False
Exit Function
End If
End With
End Function
Function VerificationNoBlankRows() As Boolean
'verification function which checks if there are no gaps between the entered records
'records should be entered one by one if there is a row after the row, which is the sum of the number of entered records and the number of rows before the records, there is a blank row somewhere
'define the range that we will check
Dim CorrectFilledRows As Integer
CorrectFilledRows = amountRecords + numberRowsBeforeRecordsClassificationWorksheet
With ThisWorkbook.Worksheets("Classification")
Dim rangeOutOfFilledRange As Range
Set rangeOutOfFilledRange = .Range(.Cells(CorrectFilledRows + 1, 2), .Cells(60, 6))
'Note: 60th row is out of table, but if the last row was 59, the condition check below gives an incorrect result if all rows in the table are filled (amountRowsFilledByApplicant + 1 = 59 + 1 = 60)
End With
'checking if there are any filled cells
Dim amountOfFilledCellsInUnwantedRange As Integer
amountOfFilledCellsInUnwantedRange = Application.WorksheetFunction.CountA(rangeOutOfFilledRange)
'return the appropriate flag, display the message
If amountOfFilledCellsInUnwantedRange = 0 Then
VerificationNoBlankRows = True
Else
VerificationNoBlankRows = False
MsgBox "Empty lines between entered records"
End If
End Function
Function VerificationRowFilling() As Boolean
With ThisWorkbook.Worksheets("Classification")
Dim rangeOfFilledRange As Range
Set rangeOfFilledRange = .Range(.Cells(numberRowsBeforeRecordsClassificationWorksheet + 1, 2), .Cells(numberRowsBeforeRecordsClassificationWorksheet + amountRecords, 6))
End With
'The condition checks whether the number of filled cells in the range (left side) corresponds to the number of cells in the range (right side)
'there is no option to fill more cells than it is in range, so else is synonymous with equality
If WorksheetFunction.CountA(rangeOfFilledRange) < rangeOfFilledRange.Count Then
VerificationRowFilling = False
MsgBox "Not all columns in the started records are filled"
Else
VerificationRowFilling = True
End If
End Function
Function VerificationClassifierEmpty() As Boolean
With ThisWorkbook.Worksheets("Classification")
Dim classifierRange As Range
Set classifierRange = .Range("G9:H59")
End With
If WorksheetFunction.CountA(classifierRange) = 0 Then 'no filled cells in the given range (part of the table for the classifier)
VerificationClassifierEmpty = True
Else
VerificationClassifierEmpty = False
MsgBox "Classifier range should be empty"
End If
End Function
Sub SendingEmail()
Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.logon
Set Outmail = OutApp.CreateItem(0)
On Error Resume Next
'fill out email
With Outmail
.To = ThisWorkbook.Worksheets("Backend").Range("B3").Value2 & "test"
.Subject = GenerateEmailSubject
.Display
.HTMLBody = GenerateEmailContent & .HTMLBody 'function generating the content of the e-mail (text, table preview) and adding a footer
SaveSignature 'save the signature which will be used in filling BatchLoad
ThisWorkbook.Save 'save the file so that after adding it as an attachment to the e-mail there would be all the data entered (records and signature)
.Attachments.Add ThisWorkbook.FullName
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
End Sub
Function GenerateEmailSubject() As String
Dim text As String
text = "Adding classification to the project - "
GenerateEmailSubject = text & ThisWorkbook.Worksheets("Classification").Range("F3").Value2
End Function
Function GenerateEmailContent() As String
'defining range of data to be copied to the e-mail
Dim tableRange As Range
Dim textRange As String
textRange = "A1:F" & numberRowsBeforeRecordsClassificationWorksheet + amountRecords + 1
Set tableRange = ThisWorkbook.Worksheets("Classification").Range(textRange)
'email content
Dim head As String, body As String
'before tabel
head = "<HTML><BODY>Hello"
body = "<BR />I need to classify these parts for our project"
'tabel from excel
body = body & RangetoHTML(tableRange)
'after tabel
body = body & "<BR />Thank you!"
GenerateEmailContent = head & body
End Function
Function ApplicantEmail() As String
Dim text As String
Dim olApp As Object
Set olApp = CreateObject("outlook.application")
text = olApp.Session.CurrentUser.Name 'example: "Surname, Name xyz xyz xyz - xyz xyz"
Dim commaAfterSurname As Integer, spaceAfterName As Integer
commaAfterSurname = InStr(1, text, ",")
spaceAfterName = InStr(commaAfterSurname + 2, text, " ")
Dim Name As String, Surname As String
Surname = Left(text, commaAfterSurname - 1)
Name = Mid(text, commaAfterSurname + 2, spaceAfterName - commaAfterSurname - 2)
ApplicantEmail = UCase(Name) & "." & UCase(Surname) & "@domain.com"
End Function
Function ClassiferEmail() As String
'prepare
Dim path As String
path = ThisWorkbook.Worksheets("Backend").Range("B2").Value2
Dim externalFile As Workbook
Set externalFile = Module3.OpenAndSetFile(path)
Dim classifier As String
classifier = ThisWorkbook.Worksheets("Classification").Range("F5").Value2
Dim classifiersAmount As Integer
Const numberRowsBeforeRecordsClassifierWorkBook = 1
With externalFile.Worksheets(2)
classifiersAmount = .Cells(.Rows.Count, "A").End(xlUp).Row - numberRowsBeforeRecordsClassifierWorkBook
End With
'finding classifier email
externalFile.Worksheets(2).Cells.AutoFilter
externalFile.Worksheets(2).Range("C1:D" & classifiersAmount + 1).AutoFilter Field:=3, Criteria1:=classifier
ClassiferEmail = externalFile.Worksheets(2).Range("D2:D" & classifiersAmount + 1).SpecialCells(xlCellTypeVisible)
externalFile.Close SaveChanges:=False
End Function
Function RangetoHTML(rng As Range)
'donwloaded from: https://www.reddit.com/r/excel/comments/37ppo4/how_to_copy_excel_cells_into_a_outlook_email/
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publish the sheet to an .htm file.
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read all data from the .htm file into the RangetoHTML subroutine.
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Close TempWB.
TempWB.Close SaveChanges:=False
' Delete the htm file.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub SaveSignature()
Dim project As String, mail As String, signature As String
project = ThisWorkbook.Worksheets("Classification").Range("F3").Value2 'Range("F3") is Project number
mail = ThisWorkbook.Worksheets("backend").Range("B3").Value2 'Range("B3") is classifier email
Dim atPosition As Integer
atPosition = InStr(1, mail, "@") 'Search @ in the email adress
mail = Left(mail, atPosition - 1)
mail = Replace(mail, ".", "")
signature = project & mail & amountRecords 'np gfdNAMESURNAME28
ThisWorkbook.Worksheets("backend").Range("B5").Value2 = signature
End Sub