I have a macro that is the most advanced I have built. However, it often crashes when saving if I have previously edited or ran it in my workbook. I typically get an "Out of Memory" error message and have recently received a "Automation error Catastrophic failure" error message.
Bellow is the entirety of my code. This is definitely already pushing the limits of my vba knowledge so can someone help identify the cause and give an explanation to understand the theory behind it to help me take that next step. I know this will take some time so thanks in advanced to anyone who takes the time.
Bellow is the entirety of my code. This is definitely already pushing the limits of my vba knowledge so can someone help identify the cause and give an explanation to understand the theory behind it to help me take that next step. I know this will take some time so thanks in advanced to anyone who takes the time.
Code:
Sub Related_BA()
Dim wb As Workbook
Dim ws As Worksheet
Dim filename As Variant
Dim returnVAlue As Variant
Dim BAwb As Workbook
Dim BAws As Worksheet
Dim BArng As Range
Dim LastRow As Integer
Dim i As Integer
Dim rng As Range
filename = Application.GetOpenFilename(filefilter:="Excel Files (*xls), *xls", Title:="Please select BA refernce file")
If filename = False Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
LastRow = ws.Range("A1").CurrentRegion.Rows.Count
Set rng = ws.Range("A2:J" & LastRow)
With rng
.HorizontalAlignment = xlCenter
End With
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ws.Range("A:B").EntireColumn.Insert
Set BAwb = Application.Workbooks.Open(filename)
Set BAws = BAwb.Worksheets("Sheet1")
Set BArng = BAws.ListObjects("DepartmentBA").DataBodyRange
On Error Resume Next
For i = 2 To LastRow
ws.Cells(i, 1) = Application.WorksheetFunction.VLookup(ws.Cells(i, 6), BArng, 2, 0)
Next i
On Error Resume Next
For i = 2 To LastRow
ws.Cells(i, 2) = Application.WorksheetFunction.VLookup(ws.Cells(i, 6), BArng, 3, 0)
Next i
BAwb.Close False
ws.Columns("A:B").EntireColumn.AutoFit
ws.Range("B2").CurrentRegion.Sort key1:=ws.Range("B2"), order1:=xlAscending, _
key2:=ws.Range("C2"), order2:=xlAscending, Header:=xlYes
Call SendEmail
ws.Range("A:B").EntireColumn.Delete
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
rng.Borders(xlEdgeLeft).LineStyle = xlNone
rng.Borders(xlEdgeTop).LineStyle = xlNone
rng.Borders(xlEdgeBottom).LineStyle = xlNone
rng.Borders(xlEdgeRight).LineStyle = xlNone
rng.Borders(xlInsideVertical).LineStyle = xlNone
rng.Borders(xlInsideHorizontal).LineStyle = xlNone
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub SendEmail()
Dim cBA As Collection
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim vNum As Variant
Dim lRow As Integer
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A2:A" & lRow)
Set rng2 = ws.Range("A1:A" & lRow)
Set cBA = New Collection
On Error Resume Next
For Each cell In rng.Cells
cBA.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0
On Error Resume Next
cBA.Remove ("None")
'Not removing #N/A to have email containging orphans display
Worksheets("Super User Report").AutoFilterMode = False
For Each vNum In cBA
rng2.AutoFilter Field:=1, Criteria1:=vNum
Call Email(vNum)
'rng2.AutoFilter Field:=1
Next vNum
Worksheets("Super User Report").AutoFilterMode = False
End Sub
Sub Email(BA As Variant)
Dim wb As Workbook
Dim ws As Worksheet
Dim lRow As Integer
Dim StrBody As String
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Mnth As Variant
Dim Yr As Variant
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = ws.Range("C1:L" & lRow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
' MsgBox "The selection is not a range or the sheet is protected" & _
' vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' StrBody = wb.Sheets("Controls").Range("A6").Value & "
"
StrBody = "Hello," & "
" & _
"Multiple email lines containing sensitive information deleted in example"
Mnth = Format(Date, "mmmm yyyy")
On Error Resume Next
With OutMail
.To = BA
.CC = ""
.BCC = ""
.Subject = "Monthly Super User Training Report " & Mnth
.HTMLBody = StrBody & RangetoHTML(rng)
'.Send 'or use
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 new workbook to past the data in
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 a 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 RangetoHTML
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 we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
