I have created a code that extracts certain data from website, adds it to the sheet, then checks what day it is and modifies progress bar (only columns in sheet). Then the code saves the current result on sheet as image and finally sets it as wallpaper. At first I had to deal with "unknown" problems. I ran the code ańd it failed. But when I debugged it step by step it ran perfectly. I figured out that my Workbook had to be corrupted. So I copied the VBA to a new workbook and finally the code ran OK. After few days I started to get errors like cells object global failed etc. I read that it happens when certain objects are not sufficiently defined so I added thisworkbook.sheets(1).cells to every cells object that error appeared at. This didn't help since the errors started popping even in the most fundamental basic stuff. So I shift started the workbook at revealed the problem. Or I THINK.. The macro removes current sheet every time I run it. Few days back it did't. Simply nothing has changed.. I will paste the code below. Is the workbook corrupted again and how does one prevent it?
Option Explicit
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Auto_Open()
Call getDataFromWebsite
Call weekProgress
Call saveSheet
Call changeWallpaper
ThisWorkbook.Close SaveChanges:=False
Application.Quit
End Sub
Sub getDataFromWebsite()
Dim x As String
Dim IE As Object
Dim HtmlCon As HTMLDocument
Dim element As Object
Dim ArrivalTime
On Error GoTo Handler
x = "someWebsite"
Set IE = New InternetExplorerMedium
IE.Navigate (x)
IE.Visible = False
Do While IE.ReadyState <> 4
DoEvents
Loop
Set HtmlCon = IE.document
Set element = HtmlCon.getElementsByClassName("someclassname")
ArrivalTime = element(0).innerText
ThisWorkbook.Sheets(1).Cells(3, 15).Value = ArrivalTime
Handler:
IE.Quit
End Sub
Sub weekProgress()
Dim caseResult As String
Dim offsetDayIndex As Integer
Const dayBarLenght = 2
Select Case Application.WorksheetFunction.Weekday(Date, 2)
Case 1
caseResult = "Monday"
offsetDayIndex = 0
Case 2
caseResult = "Tuesday"
offsetDayIndex = 1
Case 3
caseResult = "Wednesday"
offsetDayIndex = 2
Case 4
caseResult = "Thursday"
offsetDayIndex = 3
Case 5
caseResult = "Friday"
offsetDayIndex = 4
Case Else
caseResult = "Monday"
End Select
DoEvents
ThisWorkbook.Sheets(1).Cells(24, 11).Value = caseResult
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 12)).Interior.ColorIndex = 1
If Not caseResult = "Monday" Then
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 4 + (dayBarLenght * offsetDayIndex))).Interior.ColorIndex = 2
End If
End Sub
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
DoEvents
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
DoEvents
DoEvents
oCht.Chart.Paste
DoEvents
DoEvents
oCht.Chart.Export Filename:="somepath\savedImage.bmp", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub
Sub changeWallpaper()
Dim strImagePath As String
strImagePath = "somepath\savedImage.bmp"
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
Sub saveSheetBackup()
Dim oCht
Worksheets("List1").Range("B2:Q37").CopyPicture xlScreen, xlBitmap
Application.DisplayAlerts = False
Set oCht = Charts.Add
DoEvents
oCht.Paste
DoEvents
oCht.Export Filename:="somepath\savedImage.bmp", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub
I have had an epiphany. I have substituted the Thisworkbook.Close with simple Application.Quit with alerts disabled and this did the trick. I still don't quite understand why shutting down workbook without saving would delete the sheet altogether. Someone can enlighten me?
Related
I have created an UserForm in Excel. The UserForm has a ListBox and a CheckBox added to it.
I have written VBA code to populate the ListBox with data in the 1st column of the UserForm_Data worksheet. I am attempting to add a Select All CheckBox to the UserForm. When I click on the CheckBox once, the check mark does not appear but the If Me.CheckBox.Value = True section of the Checkbox1_Change event is executed and all the items in the ListBox are selected. The check mark appears only when I click the CheckBox the second time. The Excel VBA code and an image of the UserForm are attached.
Option Explicit
Private Sub ListBox1_Change()
Dim i As Long
If CheckBox1.Value = True Then
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = False Then
Me.CheckBox1.Value = False
End If
Next i
End If
End Sub
Private Sub CheckBox1_Change()
Dim i As Long
If Me.CheckBox1.Value = True Then
With Me.ListBox1
For i = 0 To .ListCount - 1
.Selected(i) = True
Next i
End With
Else
i = 0
End If
End Sub
Private Sub UserForm_Initialize()
Dim rng1 As Range
Dim ws1 As Worksheet
Dim i, lastRow As Long
Dim list1 As Object
Dim string1 As String
Dim array1 As Variant
Set list1 = CreateObject("System.Collections.ArrayList")
Set ws1 = ThisWorkbook.Worksheets("UserForm_data")
lastRow = ws1.UsedRange.Rows.Count
Me.ListBox1.Clear
For i = 2 To lastRow
string1 = CStr(ws1.Cells(i, 1).Value)
If Not list1.Contains(string1) Then
list1.Add string1
End If
Next i
array1 = list1.ToArray
Me.Caption = "UserForm1"
Me.ListBox1.list = array1
Me.ListBox1.MultiSelect = 1
Me.CheckBox1.Value = False
End Sub
There are two steps you can take to address this:
There's a chance that simply adding a DoEvents at the end of the CheckBox1_Change event will force the redraw.
If that doesn't work, add the following line just above the DoEvents and test it again... this encourages a screen update...
Application.WindowState = Application.WindowState
One approach is to use global flags to toggle on and off the control event handlers. Here is what the updated events would look like:
Option Explicit
Private Sub ListBox1_Change()
Dim i As Long
If Not AllowListBoxEvents Then Exit Sub
AllowCheckBoxEvents = False
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = False Then CheckBox1.Value = False
Next i
End If
AllowCheckBoxEvents = True
End Sub
Private Sub CheckBox1_Change()
Dim i As Long
If Not AllowCheckBoxEvents Then Exit Sub
AllowListBoxEvents = False
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
ListBox1.Selected(i) = True
Next i
End If
AllowListBoxEvents = True
End Sub
Make sure you set the "Allow" variables to True in the Initialize event.
My goal was to make autocomplete active for dropdowns and I have achieved it for a single worksheet but duplicating the code to other worksheets is not working.
I started by creating a combo Box on the initial worksheet containing the drop downs and then made the following changes-
Changed the name to TempCombo in the Name field
Selected 1-fmMatchEntryComplete in the MatchEntry field;
I then inserted the following code for that worksheet:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal
`Shift As Integer)`
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
This implementation works perfectly for that sheet but when i attempt to use the same code on another worksheet on the same file the autocomplete function doesn't work.
I attempted modification of the combobox name on sheet2 to TempCombo2 and changed the following line:
Set xCombox = xWs.OLEObjects("TempCombo")
to
Set xCombox = xWs.OLEObjects("TempCombo2")
The autocomplete function fails to work on sheet 2 even though no error is thrown.
This is a pretty interesting idea, I like it.
I was able to get this to work on multiple sheets with the following modifications:
Removed Cancel = True, this line was throwing an error and Cancel is not an argument in Worksheet_SelectionChange; I don't think this is doing anything.
Copied the code to the second sheet's code module (it has to be in each sheet module that you want it to run on)
updated Set xCombox = xWs.OLEObjects("TempCombo") to Set xCombox = xWs.OLEObjects("TempCombo2")
Me.TempCombo.DropDown updated to Me.TempCombo2.DropDown since that is what I named the combo box on the second sheet
Also, not a change as much as an assumption, it seems it only works with the ActiveX controls, so I assume that's what you are using when you add the new box.
As a follow up I was able to get it to work using the workbook module as long as the combo box is named "TempCombo" on all sheets (you have to add a combobox named "TempCombo" to each sheet). Going this route, you only need the code once, on the workbook module , and it uses the combo box that is local to each sheet.
TO TEST - In a new workbook: add list validation to a range using a range reference, put some values in the list range, add an ActiveX combobox to the sheet and name it "TempCombo", put the following code in the workbook module, then click anywhere in the range that has the list validation enabled.
One other note, make sure you aren't still in design mode on the developer tab!
Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Set xWs = Sh
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
'Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Sh.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
I am creating a marquee text in Excel 2013. As the Microsoft Web Browser Control doesn't work in Excel 2013 and 2016, so I used the following VBA code:
Sub DoMarquee()
Dim sMarquee As String
Dim iWidth As Integer
Dim iPosition As Integer
Dim rCell As Range
Dim iCurPos As Integer
'Set the message to be displayed in this cell
sMarquee = "This is a scrolling Marquee."
'Set the cell width (how many characters you want displayed at once
iWidth = 10
'Which cell are we doing this in?
Set rCell = Sheet1.Range("M2")
'determine where we are now with the message. InStr will return the position
' of the first character where the current cell value is in the marquee message
iCurPos = InStr(1, sMarquee, rCell.Value)
'If we are position 0, then there is no message, so start over
' otherwise, bump the message to the next characterusing mid
If iCurPos = 0 Then
'Start it over
rCell.Value = Mid(sMarquee, 1, iWidth) Else
'bump it
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
End If
'Set excel up to run this thing again in a second or two or whatever
Application.OnTime Now + TimeValue("00:00:01"), "DoMarquee"
End Sub
It is reflecting in excel every second, is there a way to reflect in milliseconds so that it can show some smooth running. And more issue is, it again starts only after scrolling completely. Is there anyway to make it in a scroll continuously with waiting for the entire text to scroll.
For your sub second functionality use an API call.
Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DoMarquee()
Dim sMarquee As String
Dim iWidth As Long
Dim iPosition As Long
Dim rCell As Range
Dim iCurPos As Long
sMarquee = "This is a scrolling Marquee."
iWidth = 10
Set rCell = Sheet1.Range("M2")
iCurPos = InStr(1, sMarquee, rCell.Value)
If iCurPos = 0 Then
rCell.Value = Mid(sMarquee, 1, iWidth)
Else
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
End If
Sleep 100
Application.Run "DoMarquee"
End Sub
Drop the PtrSafe if on 32 bit machine so becomes:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Edit:
1) A number of users have noted out of stack space messages to frequency of calls.
#Sorceri has correctly pointed out you can re-work as:
Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
2) I was unaware of the letter by letter part so I will refer you to his/her answer on the pulling of iWidth into global variable.
That in mind, you may wish to amend the following to take account of #Sorceri's iWidth; I have the following version 2 "fudge" for the hyperlink, amended for out-of-stack, and which includes a test for 32 v 64 bit versions to ensure compatibility. More info on compatibility here.
Version 2:
Option Explicit
#If Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Public Sub DoMarquee()
Dim sMarquee As String
Dim iWidth As Long
Dim iPosition As Long
Dim rCell As Range
Dim iCurPos As Long
sMarquee = "This is a scrolling Marquee."
iWidth = 10
Set rCell = Sheet1.Range("M2")
rCell.Parent.Hyperlinks.Add Anchor:=rCell, Address:="https://www.google.co.uk/", TextToDisplay:=rCell.Text
rCell.Font.ThemeColor = xlThemeColorDark1
iCurPos = InStr(1, sMarquee, rCell.Value)
If iCurPos = 0 Then
rCell.Value = Mid(sMarquee, 1, iWidth)
rCell.Hyperlinks(1).TextToDisplay = rCell.Text
FormatCell rCell
Else
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
On Error Resume Next
rCell.Hyperlinks(1).TextToDisplay = rCell.Text
On Error GoTo 0
FormatCell rCell
End If
Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
End Sub
Public Sub FormatCell(ByVal rng As Range)
With rng.Font
.Name = "Calibri"
.Size = 11
.Underline = xlUnderlineStyleSingle
.Color = 16711680
End With
End Sub
I couldn't get the example to stop the stack out of space as there were to many calls on the stack to the DoMarquee method. Plus I thought a marquee wrote it out character by character. So using Application.OnTime event to create the marquee. I also took out the iWidth and made it a global variable.
Option Explicit
Private iWidth As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DoMarquee()
Dim sMarquee As String
Dim iPosition As Long
Dim rCell As Range
Dim iCurPos As Long
Dim txtMarquee As String
sMarquee = "This is a scrolling Marquee."
Set rCell = Sheet1.Range("M2")
'check to see if the cell is empty
If rCell.Value = "" Then
'set the current position to 0 and iWidth to 0
iCurPos = 0
iWidth = 0
Else
'not blank so writing has started. Get the position of the cell text
iCurPos = InStr(1, sMarquee, rCell.Value)
End If
If iCurPos = 0 Then
'it is zero so get the first character
rCell.Value = Mid(sMarquee, iCurPos + 1, 1)
Else
If iWidth < 10 Then
'width is less then ten so we have not written out the max characters,
'continue until width is 10
iWidth = iWidth + 1
rCell.Value = Mid(sMarquee, 1, iWidth)
Else
'maxed the amount to show so start scrolling
rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
End If
End If
'release range object
Set rCell = Nothing
'Application.OnTime to stop the stack out of space
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
End Sub
Copy pasting 1 line of text from word to excel using VBA.
When the code reaches the below line I am getting the below error.
ActiveSheet.Paste
Run Time Error '1004': Paste Method Of worksheet Class Failed error
But if I click Debug button and press F8 then it's pasting the data in excel without any error.
This error occurs each time the loop goes on and pressing debug and F8 pasting the data nicely.
I did several testing and unable to find the root cause of this issue.
Also used DoEvents before pasting the data code but nothing worked.
Any suggestions?
EDIT:-
I am posting the code since both of you are saying the same. Here is the code for your review.
Sub FindAndReplace()
Dim vFR As Variant, r As Range, i As Long, rSource As Range
Dim sCurrRep() As String, sGlobalRep As Variant, y As Long, x As Long
Dim NumCharsBefore As Long, NumCharsAfter As Long
Dim StrFind As String, StrReplace As String, CountNoOfReplaces As Variant
'------------------------------------------------
Dim oWord As Object
Const wdReplaceAll = 2
Set oWord = CreateObject("Word.Application")
'------------------------------------------------
Application.ScreenUpdating = False
vFR = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion.Value
On Error Resume Next
Set rSource = Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rSource Is Nothing Then
For Each r In rSource.Cells
For i = 2 To UBound(vFR)
If Trim(vFR(i, 1)) <> "" Then
With oWord
.Documents.Add
DoEvents
r.Copy
.ActiveDocument.Content.Paste
NumCharsBefore = .ActiveDocument.Characters.Count
With .ActiveDocument.Content.Find
.ClearFormatting
.Font.Bold = False
.Replacement.ClearFormatting
.Execute FindText:=vFR(i, 1), ReplaceWith:=vFR(i, 2), Format:=True, Replace:=wdReplaceAll
End With
.Selection.Paragraphs(1).Range.Select
.Selection.Copy
r.Select
ActiveSheet.Paste'Error occurs in this line pressing debug and F8 is pasting the data
StrFind = vFR(i, 1): StrReplace = vFR(i, 2)
NumCharsAfter = .ActiveDocument.Characters.Count
CountNoOfReplaces = (NumCharsBefore - NumCharsAfter) / (Len(StrFind) - Len(StrReplace))
.ActiveDocument.UndoClear
.ActiveDocument.Close SaveChanges:=False
If CountNoOfReplaces Then
x = x + 1
ReDim Preserve sCurrRep(1 To 3, 1 To x)
sCurrRep(1, x) = vFR(i, 1)
sCurrRep(2, x) = vFR(i, 2)
sCurrRep(3, x) = CountNoOfReplaces
End If
CountNoOfReplaces = 0
End With
End If
Next i
Next r
End If
oWord.Quit
'Some more gode goes here... which is not needed since error occurs in the above loop
End Sub
If you want to know why I have chosen word for replacement then please go through the below link.
http://www.excelforum.com/excel-programming-vba-macros/1128898-vba-characters-function-fails-when-the-cell-content-exceeds-261-characters.html
Also used the code from the below link to get the number of replacements count.
http://word.mvps.org/faqs/macrosvba/GetNoOfReplacements.htm
Characters(start, length).Delete() method really seems not to work with longer strings in Excel :(. So a custom Delete() method could be written which will work with decoupled formating informations and texts. So the text of the cell can be modified without loosing the formating information. HTH.
Add new class named MyCharacter. It will contain information about text and
formating of one character:
Public Text As String
Public Index As Integer
Public Name As Variant
Public FontStyle As Variant
Public Size As Variant
Public Strikethrough As Variant
Public Superscript As Variant
Public Subscript As Variant
Public OutlineFont As Variant
Public Shadow As Variant
Public Underline As Variant
Public Color As Variant
Public TintAndShade As Variant
Public ThemeFont As Variant
Add next new class named MyCharcters and wrap the code of the new
Delete method in it. With Filter method a new collection of MyCharacter is created. This collection contains only the characters which should remain. Finally in method Rewrite the text is re-written from this collection back to target range along with formating info:
Private m_targetRange As Range
Private m_start As Integer
Private m_length As Integer
Private m_endPosition As Integer
Public Sub Delete(targetRange As Range, start As Integer, length As Integer)
Set m_targetRange = targetRange
m_start = start
m_length = length
m_endPosition = m_start + m_length - 1
Dim filterdChars As Collection
Set filterdChars = Filter
Rewrite filterdChars
End Sub
Private Function Filter() As Collection
Dim i As Integer
Dim newIndex As Integer
Dim newChar As MyCharacter
Set Filter = New Collection
newIndex = 1
For i = 1 To m_targetRange.Characters.Count
If i < m_start Or i > m_endPosition Then
Set newChar = New MyCharacter
With newChar
.Text = m_targetRange.Characters(i, 1).Text
.Index = newIndex
.Name = m_targetRange.Characters(i, 1).Font.Name
.FontStyle = m_targetRange.Characters(i, 1).Font.FontStyle
.Size = m_targetRange.Characters(i, 1).Font.Size
.Strikethrough = m_targetRange.Characters(i, 1).Font.Strikethrough
.Superscript = m_targetRange.Characters(i, 1).Font.Superscript
.Subscript = m_targetRange.Characters(i, 1).Font.Subscript
.OutlineFont = m_targetRange.Characters(i, 1).Font.OutlineFont
.Shadow = m_targetRange.Characters(i, 1).Font.Shadow
.Underline = m_targetRange.Characters(i, 1).Font.Underline
.Color = m_targetRange.Characters(i, 1).Font.Color
.TintAndShade = m_targetRange.Characters(i, 1).Font.TintAndShade
.ThemeFont = m_targetRange.Characters(i, 1).Font.ThemeFont
End With
Filter.Add newChar, CStr(newIndex)
newIndex = newIndex + 1
End If
Next i
End Function
Private Sub Rewrite(chars As Collection)
m_targetRange.Value = ""
Dim i As Integer
For i = 1 To chars.Count
If IsEmpty(m_targetRange.Value) Then
m_targetRange.Value = chars(i).Text
Else
m_targetRange.Value = m_targetRange.Value & chars(i).Text
End If
Next i
For i = 1 To chars.Count
With m_targetRange.Characters(i, 1).Font
.Name = chars(i).Name
.FontStyle = chars(i).FontStyle
.Size = chars(i).Size
.Strikethrough = chars(i).Strikethrough
.Superscript = chars(i).Superscript
.Subscript = chars(i).Subscript
.OutlineFont = chars(i).OutlineFont
.Shadow = chars(i).Shadow
.Underline = chars(i).Underline
.Color = chars(i).Color
.TintAndShade = chars(i).TintAndShade
.ThemeFont = chars(i).ThemeFont
End With
Next i
End Sub
How to use it:
Sub test()
Dim target As Range
Dim myChars As MyCharacters
Application.ScreenUpdating = False
Set target = Worksheets("Demo").Range("A1")
Set myChars = New MyCharacters
myChars.Delete targetRange:=target, start:=300, length:=27
Application.ScreenUpdating = True
End Sub
Before:
After:
To make it more stable, you should:
Disable all events while operating
Never call .Activate or .Select
Paste directly in the targeted cell with WorkSheet.Paste
Cancel the Copy operation with Application.CutCopyMode = False
Reuse the same document and not create one for each iteration
Do as less operations as possible in an iteration
Use early binding [New Word.Application] instead of late binding [CreateObject("Word.Application")]
Your example refactored :
Sub FindAndReplace()
Dim dictionary(), target As Range, ws As Worksheet, cell As Range, i As Long
Dim strFind As String, strReplace As String, diffCount As Long, replaceCount As Long
Dim appWord As Word.Application, content As Word.Range, find As Word.find
dictionary = [Sheet1!A1].CurrentRegion.Value
Set target = Cells.SpecialCells(xlCellTypeConstants)
' launch and setup word
Set appWord = New Word.Application
Set content = appWord.Documents.Add().content
Set find = content.find
find.ClearFormatting
find.Font.Bold = False
find.replacement.ClearFormatting
' disable events
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
' iterate each cell
Set ws = target.Worksheet
For Each cell In target.Cells
' copy the cell to Word and disable the cut
cell.Copy
content.Delete
content.Paste
Application.CutCopyMode = False
' iterate each text to replace
For i = 2 To UBound(dictionary)
If Trim(dictionary(i, 1)) <> Empty Then
replaceCount = 0
strFind = dictionary(i, 1)
strReplace = dictionary(i, 2)
' replace in the document
diffCount = content.Characters.count
find.Execute FindText:=strFind, ReplaceWith:=strReplace, format:=True, Replace:=2
' count number of replacements
diffCount = diffCount - content.Characters.count
If diffCount Then
replaceCount = diffCount \ (Len(strFind) - Len(strReplace))
End If
Debug.Print replaceCount
End If
Next
' copy the text back to Excel
content.Copy
ws.Paste cell
Next
' terminate Word
appWord.Quit False
' restore events
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
How about change it from: activesheet.paste
to:
activesheet.activate
activecell.pastespecial xlpasteAll
This post seems to explain the problem and provide two solutions:
http://www.excelforum.com/excel-programming-vba-macros/376722-runtime-error-1004-paste-method-of-worksheet-class-failed.html
Two items come to light in this post:
Try using Paste Special
Specify the range you wish to paste to.
Another solution would be to extract the targeted cells as XML, replace the text with a regular expression and then write the XML back to the sheet.
While it's much faster than working with Word, it might require some knowledge with regular expressions if the formats were to be handled. Moreover it only works with Excel 2007 and superior.
I've assemble an example that replaces all the occurences with the same style:
Sub FindAndReplace()
Dim area As Range, dictionary(), xml$, i&
Dim matchCount&, replaceCount&, strFind$, strReplace$
' create the regex object
Dim re As Object, match As Object
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.MultiLine = True
' copy the dictionary to an array with column1=search and column2=replacement
dictionary = [Sheet1!A1].CurrentRegion.Value
'iterate each area
For Each area In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants)
' read the cells as XML
xml = area.Value(xlRangeValueXMLSpreadsheet)
' iterate each text to replace
For i = 2 To UBound(dictionary)
If Trim(dictionary(i, 1)) <> Empty Then
strFind = dictionary(i, 1)
strReplace = dictionary(i, 2)
' set the pattern
re.pattern = "(>[^<]*)" & strFind
' count the number of occurences
matchCount = re.Execute(xml).count
If matchCount Then
' replace each occurence
xml = re.Replace(xml, "$1" & strReplace)
replaceCount = replaceCount + matchCount
End If
End If
Next
' write the XML back to the sheet
area.Value(xlRangeValueXMLSpreadsheet) = xml
Next
' print the number of replacement
Debug.Print replaceCount
End Sub
DDuffy's answer is useful.
I found the code can run normally at slowly cpu PC .
add the bellow code before paste, the problem is sloved：
Application.Wait (Now + TimeValue("0:00:1"))'wait 1s or more
ActiveSheet.Paste
This is an example I contrived, I created this to explain the problem I'm having. Basically I want this code to run faster than it does. On a new sheet each loop of a cell starts fast, but if you let it run to near completion, and then run it again, it will hit 100ms per cell. In my sheet I have 16000 cells with a lot of comments like this, and they are manipulated individually every time the code runs. In this example they are obviously all the same, but in the real application each one is different.
Is there anyway to make this process faster?
Option Explicit
Public Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long
Public Sub BreakTheCommentSystem()
Dim i As Integer
Dim t As Long
Dim Cell As Range
Dim dR As Range
Set dR = Range(Cells(2, 1), Cells(4000, 8))
Dim rStr As String
rStr = "ABCDEFG HIJK LMNOP QRS TUV WX YZ" & Chr(10)
For i = 1 To 5
rStr = rStr & rStr
Next i
For Each Cell In dR
t = GetTickCount
With Cell
If .Comment Is Nothing Then
.AddComment
Else
With .Comment
With .Shape.TextFrame.Characters.Font
.Bold = True
.Name = "Arial"
.Size = 8
End With
.Shape.TextFrame.AutoSize = True
.Text rStr
End With
End If
End With
Debug.Print (GetTickCount - t & " ms ")
Next
rStr = Empty
i = Empty
t = Empty
Set Cell = Nothing
Set dR = Nothing
End Sub
Update 12-11-2015, I wanted this noted somewhere in case anyone runs into it, the reason I was trying to optimize this so much was because VSTO would not let me add a workbook file with all these comments. After 6 months of working with Microsoft, this is now a confirmed bug in the VSTO and Excel.
https://connect.microsoft.com/VisualStudio/feedback/details/1610713/vsto-hangs-while-editing-an-excel-macro-enabled-workbook-xlsm-file
According to the MSDN Comments collection and Comment object documentation, you can reference all comments within a worksheet through their indexed position and deal with them directly rather than cycle through each cell and determine whether it contains a comment.
Dim c As Long
With ActiveSheet '<- set this worksheet reference properly!
For c = 1 To .Comments.Count
With .Comments(c)
Debug.Print .Parent.Address(0, 0) ' the .parent is the cell containing the comment
' do stuff with the .Comment object
End With
Next c
End With
Also according to official docs for the Range.SpecialCells method you can easily determine a subset of cells in a worksheet using the xlCellTypeComments constant as the Type parameter.
Dim comcel As Range
With ActiveSheet '<- set this worksheet reference properly!
For Each comcel In .Cells.SpecialCells(xlCellTypeComments)
With comcel.Comment
Debug.Print .Parent.Address(0, 0) ' the .parent is the cell containing the comment
' do stuff with the .Comment object
End With
Next comcel
End With
I'm still unclear with the reasoning behind filling all non-commented cells with a blank comment but if you are trying to work with the comments only on a worksheet it is better to work with the subset of commented cells rather than cycling through all cells looking for a comment.
By turning off screen updating, I was able to reduce the time for each iteration from around 100ms to around 17ms. You can add the following to the start of the procedure:
Application.ScreenUpdating = False
You can turn updating back on at the end of the procedure by setting it back to true.
This code copies the data to a new worksheet, and recreates all notes:
In a new user module:
Option Explicit
Private Const MAX_C As Long = 4000
Private Const MAIN_WS As String = "Sheet1"
Private Const MAIN_RNG As String = "A2:H" & MAX_C
Private Const MAIN_CMT As String = "ABCDEFG HIJK LMNOP QRS TUV WX YZ"
Public Sub BreakTheCommentSystem_CopyPasteAndFormat()
Dim t As Double, wsName As String, oldUsedRng As Range
Dim oldWs As Worksheet, newWs As Worksheet, arr() As String
t = Timer
Set oldWs = Worksheets(MAIN_WS)
wsName = oldWs.Name
UpdateDisplay False
RemoveComments oldWs
MakeComments oldWs.Range(MAIN_RNG)
Set oldUsedRng = oldWs.UsedRange.Cells
Set newWs = Sheets.Add(After:=oldWs)
oldUsedRng.Copy
With newWs.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormulasAndNumberFormats
.Cells(1, 1).Copy
.Cells(1, 1).Select
End With
arr = GetCommentArrayFromSheet(oldWs)
RemoveSheet oldWs
CreateAndFormatComments newWs, arr
newWs.Name = wsName
UpdateDisplay True
InputBox "Duration: ", "Duration", Timer - t
'272.4296875 (4.5 min), 269.6796875, Excel 2007: 406.83203125 (6.8 min)
End Sub
.
Other functions:
Public Sub UpdateDisplay(ByVal state As Boolean)
With Application
.Visible = state
.ScreenUpdating = state
'.VBE.MainWindow.Visible = state
End With
End Sub
Public Sub RemoveSheet(ByRef ws As Worksheet)
With Application
.DisplayAlerts = False
ws.Delete
.DisplayAlerts = True
End With
End Sub
'---------------------------------------------------------------------------------------
Public Sub MakeComments(ByRef rng As Range)
Dim t As Double, i As Long, cel As Range, txt As String
txt = MAIN_CMT & Chr(10)
For i = 1 To 5
txt = txt & txt
Next
For Each cel In rng
With cel
If .Comment Is Nothing Then .AddComment txt
End With
Next
End Sub
Public Sub RemoveComments(ByRef ws As Worksheet)
Dim cmt As Comment
'For Each cmt In ws.Comments
' cmt.Delete
'Next
ws.UsedRange.ClearComments
End Sub
'---------------------------------------------------------------------------------------
Public Function GetCommentArrayFromSheet(ByRef ws As Worksheet) As String()
Dim arr() As String, max As Long, i As Long, cmt As Comment
If Not ws Is Nothing Then
max = ws.Comments.Count
If max > 0 Then
ReDim arr(1 To max, 1 To 2)
i = 1
For Each cmt In ws.Comments
With cmt
arr(i, 1) = .Parent.Address
arr(i, 2) = .Text
End With
i = i + 1
Next
End If
End If
GetCommentArrayFromSheet = arr
End Function
Public Sub CreateAndFormatComments(ByRef ws As Worksheet, ByRef commentArr() As String)
Dim i As Long, max As Long
max = UBound(commentArr)
If max > 0 Then
On Error GoTo restoreDisplay
For i = 1 To max
With ws.Range(commentArr(i, 1))
.AddComment commentArr(i, 2)
With .Comment.Shape.TextFrame
With .Characters.Font
If .Bold Then .Bold = False 'True
If .Name <> "Calibri" Then .Name = "Calibri" '"Arial"
If .Size <> 9 Then .Size = 9 '8
If .ColorIndex <> 9 Then .ColorIndex = 9
End With
If Not .AutoSize Then .AutoSize = True
End With
DoEvents
End With
Next
End If
Exit Sub
restoreDisplay:
UpdateDisplay True
Exit Sub
End Sub
Hope this helps
I think I found 2 ways to improve performance for your task
The code in your example runs for an average of 25 minutes, I got it down to 4.5 minutes:
Create a new sheet
Copy & paste all values from the initial sheet
Copy all comments to a 2 dimensional array (cell address & comment text)
Generates the same comments for the same cells on the new sheet, with the new format
This one is quite simple to implement and test, and is very specific to your case
From the description, you are processing the same comments over and over
The most expensive part is changing the font
With this adjustment it will only update the font for the new comments (existing ones are already using the font from previous processing, even if the text gets updated)
Try updating this part of the code in the actual file (it's not as effective for the example)
With .Shape.TextFrame
With .Characters.Font
If Not .Bold Then .Bold = True
If .Name <> "Arial" Then .Name = "Arial"
If .Size <> 8 Then .Size = 8
End With
If Not .AutoSize Then .AutoSize = True
End With
or:
With .Shape.TextFrame
With .Characters.Font
If Not .Bold Then
.Bold = True
.Name = "Arial"
.Size = 8
End If
End With
If Not .AutoSize Then .AutoSize = True
End With
Let me know if you're interested in the other option and I can provide the implementation
Turn off screen updating and if you not need to workboook to recalculate during the macro, setting the calculation to manual will really shave off some time. This will prevent every formula in your workbook for processing every time you alter a cell. These two functions allow me to crunch out rather large reports in a matter of seconds.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Of course, at the end of the macro, set them back to true and automatic
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic