I have coded several macros and straight vba code into a workbook and now every time I have this workbook open - everything MSOffice runs very slowly! And on my coworkers machine which happens to be win 7 - it freezes up and then shuts down Excel... Is this normal? Is there a way to make it stop trying to run the code in the background non-stop?
-
If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
is it normal for Excel and all other Office Products to get real slow when programming macros?
So far this is what I have - a couple of them are not actually working yet... still working on the email stuff but otherwise rest are all functioning. I just got done moving them all to 1 module to see if that would reduce the latency... but it didn't help.
<code>
Sub HighlightPending()
'
' HighlightPending Macro
'
'
'Current Selection Call Sheet1.HighLightRose.Activate
End Sub
Sub RFQHistory()
'
' RFQHistory Macro
'
'
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Are you sure you want to Archive the selected data?" ' Define message.
Style = vbOK + vbCancle ' Define buttons.
Title = "Alert! Action Not Reversable!" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
' context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbOK Then ' User chose Yes.
Selection.Cut
Sheets("RFQ History").Select
Range("A2").Select
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SLA CLOCK").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Else ' User chose No.
MyString = "No" ' Perform some action.
End If
End Sub
Sub SendEmail()
'
' SendEmail Macro
'
'
Application.CutCopyMode = False
Selection.Copy
End Sub
Sub copypaste()
'
' copypaste Macro
'
'
Selection.Copy
Range("L28").Select
ActiveSheet.Paste
End Sub
Sub UpdateTime()
'
' UpdateTime Macro
'
ThisWorkbook.Worksheets("SLA CLOCK").Calculate
End Sub
Sub Mail_Range()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & ""
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Target.Cells.Count Then Exit Sub
If Not Application.Intersect(Range("J"), Target) Is Nothing Then
If isstring(Target.Value) And Target.Value = "RED" Then
Call Mail_Range
End If
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim Busted As String
Busted = Selection.Copy
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = Busted
On Error Resume Next
With OutMail
.To = "sophia.threadgall@nasa.gov"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = Busted
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub Mail_Selection_Range_Outlook_Body()
Selection.Copy
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").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
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "tracy.m.lay@nasa.gov; " & "destiny.a.corean@nasa.gov"
.CC = ""
.BCC = ""
.Subject = "OPEN/PENDING RFQ Daily Status Report"
.HTMLBody = ActiveSheet.Paste
.Display 'or use .Send
docmd.Paste
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub RangetoHTML(rng As Range)
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
ublishsource=", _
"align=left xublishsource=")
'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 Sub
Sub StopClock()
'
' StopClock Macro
'
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
ActiveCell.Offset(0, 4) = "=RC[-4]"
ActiveCell.Offset(0, 5) = "PENDING"
' ActiveCell.Offset(0, -4).Select
End Sub
Sub StartClock()
'
' StartClock Macro
'
'
ActiveCell.FormulaR1C1 = "=RC[-2]"
ActiveCell.Offset(0, 1) = "=RC[-2]+(RC[-1])"
ActiveCell.Offset(0, 2) = "=RC[-1]-now()"
ActiveCell.Offset(-1, 3).Copy
ActiveCell.Offset(0, 3).PasteSpecial (xlPasteFormulas)
End Sub
Sub FixBusted()
'
' FixBusted Macro
'
'
ActiveCell.FormulaR1C1 = "Failed"
ActiveCell.FormulaR1C1 = "RED"
End Sub
Sub newduedate()
'
' newduedate Macro
'
'
ActiveCell.FormulaR1C1 = "=RC[-2]+(RC[-5]-RC[-4])"
End Sub
Sub autofill()
'
' autofill Macro
'
'
Selection.autofill Destination:=Range("I10:J16"), Type:=xlFillDefault
Range("I10:J16").Select
End Sub
Sub Weekday()
'
' Weekday Macro
'
'
ActiveCell.FormulaR1C1 = "=SUM(RC[-1]+2)"
End Sub
Sub Weekend()
'
' Weekend Macro
'
'
ActiveCell.FormulaR1C1 = "=SUM(RC[-1]+4)"
End Sub
Sub AddLines2()
'
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
Sub Refresh()
'
' Refresh Macro
'
Range("A1:K50").Select
Range("K50").Activate
End Sub
</code>
<code>
Sub HighlightPending()
'
' HighlightPending Macro
'
'
'Current Selection Call Sheet1.HighLightRose.Activate
End Sub
Sub RFQHistory()
'
' RFQHistory Macro
'
'
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Are you sure you want to Archive the selected data?" ' Define message.
Style = vbOK + vbCancle ' Define buttons.
Title = "Alert! Action Not Reversable!" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic
' context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbOK Then ' User chose Yes.
Selection.Cut
Sheets("RFQ History").Select
Range("A2").Select
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SLA CLOCK").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Else ' User chose No.
MyString = "No" ' Perform some action.
End If
End Sub
Sub SendEmail()
'
' SendEmail Macro
'
'
Application.CutCopyMode = False
Selection.Copy
End Sub
Sub copypaste()
'
' copypaste Macro
'
'
Selection.Copy
Range("L28").Select
ActiveSheet.Paste
End Sub
Sub UpdateTime()
'
' UpdateTime Macro
'
ThisWorkbook.Worksheets("SLA CLOCK").Calculate
End Sub
Sub Mail_Range()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & ""
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Target.Cells.Count Then Exit Sub
If Not Application.Intersect(Range("J"), Target) Is Nothing Then
If isstring(Target.Value) And Target.Value = "RED" Then
Call Mail_Range
End If
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim Busted As String
Busted = Selection.Copy
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = Busted
On Error Resume Next
With OutMail
.To = "sophia.threadgall@nasa.gov"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = Busted
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub Mail_Selection_Range_Outlook_Body()
Selection.Copy
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").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
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "tracy.m.lay@nasa.gov; " & "destiny.a.corean@nasa.gov"
.CC = ""
.BCC = ""
.Subject = "OPEN/PENDING RFQ Daily Status Report"
.HTMLBody = ActiveSheet.Paste
.Display 'or use .Send
docmd.Paste
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub RangetoHTML(rng As Range)
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
ublishsource=", _"align=left x
ublishsource=")'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 Sub
Sub StopClock()
'
' StopClock Macro
'
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
ActiveCell.Offset(0, 4) = "=RC[-4]"
ActiveCell.Offset(0, 5) = "PENDING"
' ActiveCell.Offset(0, -4).Select
End Sub
Sub StartClock()
'
' StartClock Macro
'
'
ActiveCell.FormulaR1C1 = "=RC[-2]"
ActiveCell.Offset(0, 1) = "=RC[-2]+(RC[-1])"
ActiveCell.Offset(0, 2) = "=RC[-1]-now()"
ActiveCell.Offset(-1, 3).Copy
ActiveCell.Offset(0, 3).PasteSpecial (xlPasteFormulas)
End Sub
Sub FixBusted()
'
' FixBusted Macro
'
'
ActiveCell.FormulaR1C1 = "Failed"
ActiveCell.FormulaR1C1 = "RED"
End Sub
Sub newduedate()
'
' newduedate Macro
'
'
ActiveCell.FormulaR1C1 = "=RC[-2]+(RC[-5]-RC[-4])"
End Sub
Sub autofill()
'
' autofill Macro
'
'
Selection.autofill Destination:=Range("I10:J16"), Type:=xlFillDefault
Range("I10:J16").Select
End Sub
Sub Weekday()
'
' Weekday Macro
'
'
ActiveCell.FormulaR1C1 = "=SUM(RC[-1]+2)"
End Sub
Sub Weekend()
'
' Weekend Macro
'
'
ActiveCell.FormulaR1C1 = "=SUM(RC[-1]+4)"
End Sub
Sub AddLines2()
'
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
Sub Refresh()
'
' Refresh Macro
'
Range("A1:K50").Select
Range("K50").Activate
End Sub
</code>
Upvote
0
Similar threads
- Question
- Question
- Solved
