Hi guys I made the code below to search for multiple text in a given column. The problem is that it is very slow. Do guys know any other ways to perform it faster?
For example give the array ('foo', 'bar'), The code should iterate on a column and match/filter only the rows that have both texts in any given order.
Sub aTest()
ScreenUpdating = False
Dim selectedRange As Range, cell As Range
Dim searchValues() As String
searchValues = Split(ActiveSheet.Cells(2, 1).Value)
Set selectedRange = Range("A4:A40000")
Dim element As Variant
For Each cell In selectedRange
If cell.Value = "" Then
Exit For
Else
For Each element In searchValues
If Not InStr(1, cell.Value, element) Then
cell.EntireRow.Hidden = True
End If
Next element
End If
Next cell
ScreenUpdating = True
End Sub
I was using it as a filter. copied and pasted the following code with a few modifications. But then I was not able to make the changes to match multiple strings.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iFilterColumn As Integer
Dim rFilter As Range
Dim sCriteria As String
On Error Resume Next
With Target
Set rFilter = .Parent.AutoFilter.Range
iFilterColumn = .Column + 1 - rFilter.Columns(1).Column
If Intersect(Target, Range("rCriteria")) Is Nothing Then GoTo Terminator
Select Case Left(.Value, 1)
Case ">", "<"
sCriteria = .Value
Case Else
sCriteria = "=*" & .Value & "*"
End Select
If sCriteria = "=" Then
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn
Else
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn, Criteria1:=sCriteria
End If
End With
Terminator:
Set rFilter = Nothing
On Error GoTo 0
End Sub
I'm assuming this:
Set selectedRange = Range("A4:A40000")
It's because the size is not defined properly, the following should limit to the right long
Set selectedRange = Range("A4:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If it doesn't affect, I always use these codes to speed up Excel (Instead of only ScreenUpdating alone).
Sub ExcelNormal()
With Excel.Application
.Cursor = xlDefault
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.StatusBar = False
End With
End Sub
Note: In the future Probably Code Review would be better place to post.
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
I'm trying to write some VBA code that will unhide an entire row if another specific row is hidden. This macro also hides a range of rows based on the value in a specific column. This aspect works fine - I have reliable code. I can't get the first function I described to work. Should be easy to do, just don't know the syntax. This subroutine should execute upon opening the workbook.
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim targ As Range
Dim msg As Range
targ = "DETAILS!B6"
msg = "DETAILS!B42"
msg.EntireRow.Hidden = True
With Range("DETAILS!B6:B40")
.EntireRow.Hidden = False
For Each cell In Range("DETAILS!B6:B40")
Select Case cell.Value
Case Is = 0
cell.EntireRow.Hidden = True
End Select
Next cell
End With
If targ.EntireRow.Hidden = True Then
msg.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub
You need to set the variables like below
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim targ As Range
Dim msg As Range
Set targ = "DETAILS!B6"
Set msg = "DETAILS!B42"
msg.EntireRow.Hidden = True
With Range("DETAILS!B6:B40")
.EntireRow.Hidden = False
For Each cell In Range("DETAILS!B6:B40")
Select Case cell.Value
Case Is = 0
cell.EntireRow.Hidden = True
End Select
Next cell
End With
If targ.EntireRow.Hidden = True Then
msg.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub
Oh! Just put Set before targ and msg since they're a Range. When declaring ranges, you have to have Set, i.e. Set myRng = Range("A1:A10").
You might need to do Set targ = Range("Details!B6") if just Set Targ = "DetailsB6" doesn't work.
On second thought, I don't think Set Targ = "Details!B6" will work if you are Dim Targ as Range. You're dim'ing as a Range, but are declaring it as like a string. You need this to be a Range, to use it like targ.EntireRow.Hidden, etc.
Though you can call range objects like this : Range("DETAILS!B6:B40")
In vba it is better accepted to call it like this: Sheets("DETAILS").Range("B6:B40")
I fixed a few more syntax errors:
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim targ As Range
Dim msg As Range
Set targ = Sheets("DETAILS").Range("B6")
Set msg = Sheets("DETAILS").Range("B42")
msg.EntireRow.Hidden = True
With Sheets("DETAILS").Range("B6:B40")
.EntireRow.Hidden = False
End With
For Each cell In Sheets("DETAILS").Range("B6:B40")
Select Case cell.Value
Case 0
cell.EntireRow.Hidden = True
End Select
Next cell
If targ.EntireRow.Hidden = True Then
msg.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub
This would be a very simple question.
But I am not sure why this is not working in my excel vba code.
Sheets("I- ABC").Select
If IsEmpty(Range("A3").Value) = True And _
IsEmpty(Range("A4").Value) = True And _
IsEmpty(Range("A5").Value) = True And _
IsEmpty(Range("A6").Value) = True Then
Sheets("I- ABC").Delete
End If
What type of error do you get? I tried this code and Excel displays only warning message:
You can avoid this message by adding:
Application.DisplayAlerts = False
and
Application.DisplayAlerts = True
at the beginning and at the end of your code respectively.
--Edited code
Sub Example()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Application.WorksheetFunction.CountA(.Range("A3:A6")) = 0 Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
Try Similiar to This
Sub Test()
Application.DisplayAlerts = False
With Sheets("Sheet1")
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
PS: It works for me and deletes rows containg empty cells in `A:A``
Approach Suggested by #Tim Williams also works for me as per following code in my situation
Sub Test6()
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A3:A6")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
It works even if we use Application instead of WorksheetFunction
If If Application.CountA(Range("A3:A6")) = 0 Then is not working as Tim suggested then that means the cells have blank spaces or unprintable characters.
Try this
Sub Sample()
Dim pos As Long
With Sheets("I- ABC")
pos = Len(Trim(.Range("A3").Value)) + _
Len(Trim(.Range("A4").Value)) + _
Len(Trim(.Range("A5").Value)) + _
Len(Trim(.Range("A6").Value))
If pos = 0 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Else
MsgBox "The cells are not empty"
End If
End With
End Sub
With skkakkar's idea expanded.
Sub Hello()
Dim rng As Range
Application.DisplayAlerts = 0
On Error GoTo er
Set rng = Range("A3:A6").SpecialCells(xlCellTypeConstants, 23)
Exit Sub
er: MsgBox "ActiveSheet.Delete" 'delete sheet
End Sub
If the spaces are the issue, then you can try this code:
Public Sub RemoveIfEmpty()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Trim(.Range("A3") & .Range("A4") & .Range("A5") & .Range("A6")) = "" Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub
I am creating macro which will loop through column F and will delete month april from 2013. It seem that the macro is deleting all :-D. I dont know how to set it to delete only my criteria I tried (Month(Now) - 2). Mine date of format looks like DD/MM/YYYY.
Thank you for your help.
Sub Test1()
Dim rgFoundCell As Range
Dim toBeDeted As Range
Dim firstAddress
With Sheets("Sheet1").Range("F:F")
Set rgFoundCell = .Find(What:=(Month(Now) - 2))
If Not rgFoundCell Is Nothing Then
firstAddress = rgFoundCell.Address
Do
If toBeDeted Is Nothing Then
Set toBeDeted = rgFoundCell.EntireRow
Else
Set toBeDeted = Union(toBeDeted, rgFoundCell.EntireRow)
End If
Set rgFoundCell = .FindNext(rgFoundCell)
If rgFoundCell Is Nothing Then Exit Do
Loop While rgFoundCell.Address <> firstAddress
End If
End With
Application.ScreenUpdating = True
If Not toBeDeted Is Nothing Then _
toBeDeted.Delete ' Delete
End Sub
You can't use .Find in the way you think - it is only able to do text match or number match comparisons. This leaves you with having to cycle through each cell in the range and run your comparison explicitly on each cell
Sub Test1()
Dim toBeDeleted As Range
With Sheets("Sheet1").Range("F:F")
For Each c In .Cells
If Month(c.Value) = 3 And Year(c.Value) = 2013 Then
If toBeDeleted Is Nothing Then
Set toBeDeleted = c.EntireRow
Else
Set toBeDeleted = Union(toBeDeleted, c.EntireRow)
End If
End If
Next
End With
If Not toBeDeleted Is Nothing Then _
toBeDeleted.Delete ' Delete
End Sub
You might want to consider running the function on a more refined range than the full F column or use an end of data marker like checking for a blank row to stop the loop.
Try this:
Sub Test1()
On Error GoTo e
Application.ScreenUpdating = False
Dim rng As Range
Dim firstAddress
Set rng = Sheets("Sheet1").Range("F1", Sheets("Sheet1").Range("F1").End(xlDown))
Dim i As Long
i = 1
While i <= rng.Count
If Month(CDate(rng(i))) = 4 And Year(CDate(rng(i))) = 2014 Then
rng (i).EntireRow.Delete
Else
i = i + 1
End If
Wend
x:
Application.ScreenUpdating = True
Exit Sub
e:
MsgBox (Err.Description)
Resume x
End Sub
Maybe try to reduce the F:F range!!!