Looping through cell values in Excel VBA - vba

I have been trying to write a program that will loop through all the cells in an excel sheet and if one starts with a '#' it should display a message. here's the code:
(template is a worksheet variable)
Private Function processTemplate()
Dim total As Long
total = template.UsedRange.count
Dim count As Integer
count = 0
While count <= total
If template.Cells(count).Value Like "[#]*" Then 'Here I get a error
MsgBox "Found #"
End If
count = count + 1
Wend
End Function
I have isolated the error to using a variable inside of cells(). If I replace count with some number (like 8) it works fine. I am getting error 1004 on the line If template.Cells(count).Value Like "[#]*" Then
If I make total an Integer it has the same error at the same place. After about 2-3 hrs of research/banging my head on the wall I have no idea. I initially got the error when assigning template.cells(row, col).Value to a string variable.
Here's my code now:
Private Sub processTemplate()
MsgBox Len("")
Dim str As String
Dim rows As Long
Dim cols As Long
rows = template.UsedRange.Height
cols = template.UsedRange.Width
Dim row As Integer
row = 1
While row < rows
Dim col As Integer
col = 1
While col < cols
str = template.Cells(row, col).Text
If Len(str) > 0 Then
If Left(template.Cells(row, col).Text, 1) = "#" Then
MsgBox "Found IT"
End If
End If
Rem MsgBox template.Parent.Name & ": " & template.Name & ", Cell(" & row & ", " & col & "): " & template.Cells(row, col).Value
col = col + 1
Wend
row = row + 1
Wend
End Sub
Now I get the error on str = template.Cells(row, col).Text

We can use a sub rather than a function
We loop over all the cells in UsedRange looking for a # as the first character in the cell.
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
Next r
End Sub
EDIT#1
This version loops over all the cells, but does not test cells containing formulas
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If r.HasFormula = False Then
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
End If
Next r
End Sub

You could use find/ find next function which i guess bit faster than looping through each cell and do string comparison.
With Worksheets(1).Range("a1:a500") 'Provide the search range
Set c = .Find(2, lookin:=xlValues) ' searching for 2 in cell value
If Not c Is Nothing Then
firstAddress = c.Address 'first occurance
Do
'do whatever you want to do with the matches even replace them
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Reference:
http://msdn.microsoft.com/en-us/library/office/ff196143(v=office.15).aspx

Related

Format pasted rows within userforum-textbox into concatenation or borderline?

I get a mismatch error in this line :
row_str = Join(cell_rng, Chr(10))
Thank you. I am intermediate.
I attached a piece of the code below:
Dim last_row As String
Dim last_col As String
Dim office_str As String
Dim lookupVal As String
Dim i As Long
Dim seperate_cells, cell_rng As Range
Dim r As Range
Dim row_str As String
With Contacts
For i = 2 To last_row
Set cell_rng = Rows(i & ":" & i + 1)
For Each r In cell_rng.Rows
seperate_cells = cellsSeparator(r.SpecialCells(xlCellTypeConstants))
If row_str = "" Then
row_str = Join(cell_rng, Chr(10))
Else
row_str = row_str & vbLf & Join(cell_rng, Chr(10))
End If
Next
Debug.Print row_str
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & row_str
Next i
End With
````
Please try the next way. It will place the values of the necessary specific row in the text box, each value separated by " | ":
Sub testSeparatorsBetweenRowCells()
'your existing code...
Dim arr, rngR As Range
For i = 2 To last_row
lookupVal = cells(i, office_str)
' Compare ComboBox with the range from the spreadsheet
If lookupVal = Office_Code Then
Set rngR = rows(i & ":" & i).SpecialCells(xlCellTypeConstants) 'Set a range which will return all cells value in the row, except the empty ones
arr = arrCells(rngR) 'call a function able to make an array from the range set in the above line
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & Join(arr, " | ") 'add the text obtained by joining the array to the next line of existing text
End If
Next i
End Sub
Function arrCells(rng As Range) As Variant
Dim arr, Ar As Range, i As Long, C As Range
ReDim arr(rng.cells.count - 1) 'ReDim the array to be filled as the range cells number.
'- 1, because the array is 0 based...
For Each Ar In rng.Areas 'iterate between the range areas
For Each C In Ar.cells 'iterate between cells of each area
arr(i) = C.value: i = i + 1 'put each cell value in the array
Next
Next
arrCells = arr 'make the function returning the arr
End Function
If the text in the text box still goes on the next line, try making the text box property WordWrap False. If you cannot see all the text, make the textbox wider or decrease its font size.
Please, test it and send some feedback.
Edited:
Please, try understanding the next piece of code, able to deal with copying more rows at once:
Sub testCopyingMoreRows()
Dim sh As Worksheet, i As Long, rng As Range, r As Range, arr, strRow As String
Set sh = ActiveSheet
i = 9
Set rng = sh.rows(i & ":" & i + 1)
'you ca select cells, rows (even not consecutive) and use:
'Set rng = Selection.EntireRow 'just uncomment this code line...
'extract rows and paste their contents (exept the empty cells) in Imediate Window
For Each r In rng.rows
arr = arrCells(r.SpecialCells(xlCellTypeConstants))
If strRow = "" Then
strRow = Join(arr, " | ")
Else
strRow = strRow & vbLf & Join(arr, " | ")
End If
Next
Debug.Print strRow
'instead returning in Imediate Window, you can do it in your text box (uncomment the next line):
'Client_Finder.result.Text = Client_Finder.result.Text & vbLf & strRow
End Sub
The code uses the same function arrCells...

Find the cell adresses for each cell that starts with a specific number

I am looking for a code, that can find each cell that starts with the number "2347" in column L. I want to get the cell adresses for these cells and display it in a MessageBox for example "Msgbox: Cells L3500:L3722 has a value starts starts with "2347" "
Sub Findrow()
Dim MyVal As Integer
Dim LastRow As Long
MyVal = LEFT(c.Value,4) = "2347" _
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For Each c In Range("L2:L" & LastRow)
If c.Value = Myval Then
This is my code so far. Hope someone can help me!
Using arrays is quite fast
Option Explicit
Public Sub FindIDInColL()
Const VID = "2347" 'Value to find
Dim ws As Worksheet, arrCol As Variant, found As Variant
Set ws = ActiveSheet 'Or Set ws = ThisWorkbook.Worksheets("Sheet3")
arrCol = ws.Range(ws.Cells(2, "L"), ws.Cells(ws.Rows.Count, "L").End(xlUp))
ReDim found(1 To UBound(arrCol))
Dim r As Long, f As Long, msg As String
f = 1
For r = 1 To UBound(arrCol) 'Iterate vals in col L, excluding header row
If Not IsError(arrCol(r, 1)) Then 'Ignore errors
If Len(arrCol(r, 1)) > 3 Then 'Check only strings longer than 3 letters
If Left$(arrCol(r, 1), 4) = VID Then 'Check first 4 letters
found(f) = r + 1 'Capture rows containing value (header offset)
f = f + 1
End If
End If
End If
Next
If f > 1 Then 'If any cells found
ReDim Preserve found(1 To f - 1) 'Drop unused array items
msg = "Cells in col L starting with """ & VID & """" & vbNewLine & vbNewLine
MsgBox msg & " - L" & Join(found, ", L"), , "Total Found: " & f - 1
Else
MsgBox "No cells starting with """ & VID & """ found in col L", , "No matches"
End If
End Sub
Even faster when using the string versions of these functions
Left$() Mid$() Right$() Chr$() ChrW$() UCase$() LCase$()
LTrim$() RTrim$() Trim$() Space$() String$() Format$()
Hex$() Oct$() Str$() Error$
They are more efficient (if Null is not a concern), as pointed out by QHarr
You may try this:
Option Explicit
Sub Findrow()
Dim MyVal As String ' "2347" is a String
Dim LastRow As Long
Dim c As Range, myCells As Range
MyVal = "2347"
LastRow = cells(Rows.Count, "L").End(xlUp).row
Set myCells = Range("M2") 'initialize cells with a dummy cell certainly out of relevant one
For Each c In Range("L2:L" & LastRow)
If Left(c.Value2, 4) = MyVal Then Set myCells = Union(myCells, c) ' if current cell matches criteria then add it to cells
Next
If myCells.Count > 1 Then MsgBox "Cells " & Intersect(myCells, Range("L:L")).Address(False, False) & " have values starting with ‘2347’" ' if there are other cells than the dummy one then get rid of this latter and show their addresses
End Sub

Deleting duplicate text in a cell in excel

I was wondering how to remove duplicate names/text's in a cell. For example
Jean Donea Jean Doneasee
R.L. Foye R.L. Foyesee
J.E. Zimmer J.E. Zimmersee
R.P. Reed R.P. Reedsee D.E. Munson D.E. Munsonsee
While googling, I stumbled upon a macro/code, it's like:
Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
xChar = VBA.Mid(xValue, i, 1)
If xDic.exists(xChar) Then
Else
xDic(xChar) = ""
xOutValue = xOutValue & xChar
End If
Next
RemoveDupes1 = xOutValue
End Function
The macro is working, but it is comparing every letter, and if it finds any repeated letters, it's removing that.
When I use the code over those names, the result is somewhat like this:
Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno
By looking at the result I can make out it is not what I want, yet I got no clue how to correct the code.
The desired output should look like:
Jean Donea
R.L. Foye
J.E. Zimmer
R.P. Reed
Any suggestions?
Thanks in Advance.
Input
With the input on the image:
Result
The Debug.Print output
Regex
A regex can be used dynamically iterating on the cell, to work as a Find tool. So it will extract only the shortest match. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*, e.g.: \w*(Jean)\w*
The Regex's reference must be enabled.
Code
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
EXTRACTELEMENT = 0
On Error GoTo 0
End Function
Sub test()
Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
str = Range("A" & Row)
F_str = ""
N_Elements = UBound(Split(str, " "))
If N_Elements > 0 Then
For k = 1 To N_Elements + 1
strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
With objRegExp
.Pattern = strPattern
.Global = True
End With
If objRegExp.test(strPattern) Then
Set objMatches = objRegExp.Execute(str)
If objMatches.Count > 1 Then
If objRegExp.test(F_str) = False Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
ElseIf k <= 2 And objMatches.Count = 1 Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
End If
Next k
Else
F_str = str
End If
Debug.Print Trim(F_str)
Next Row
End Sub
Note that you can Replace the Debug.Print to write on the target
cell, if it is column B to Cells(Row,2)=Trim(F_str)
Explanation
Function
You can use this UDF, that uses the Split Function to obtain the element separated by spaces (" "). So it can get every element to compare on the cell.
Loops
It will loop from 1 to the number of elements k in each cell and from row 1 to lastrow.
Regex
The Regex is used to find the matches on the cell and Join a new string with the shortest element of each match.
This solution operates on the assumption that 'see' (or some other three-letter string) will always be on the end of the cell value. If that isn't the case then this won't work.
Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String
'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))
'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x
'if it's more than one, set to str, otherwise error
If ct > 1 Then
RemoveDupeInCell = str
Else
RemoveDupeInCell = "#N/A"
End If
End Function

VBA - How to match headers from two different sheet to make sure they are same name and at same order?

I have two excel sheet ReportOld and ReportNew, what I want to check and make sure all the column herder from both sheets are matching name and in same order. Basically need to check there should not be any new column added or removed from last report.. bot are identical.
Till now I tried the code is:
Sub colLookup()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range
Dim headerOne As Range, headerTwo As Range
Dim x As Integer
Dim lastCol As Long
Set ShtOne = Sheets("ReportOld")
Set ShtTwo = Sheets("ReportNew")
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
For Each headerTwo In shtTwoHead
For Each headerOne In shtOneHead
If headerTwo.Value = headerOne.Value Then
Else
x = MsgBox("Headers are not matching in both sheets.")
MsgBox "value is:" & headerTwo.Value
Exit Sub
End If
Next headerOne
Next headerTwo
End Sub
Try this code. It counts the headings on both sheets and fills an array of headings from both sheets. Then it compares the headings one each sheet and displays a message if the headings don't match. It then compares the number of columns and if they don't match, another message is displayed...
Sub colLookup()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range
Dim headerOne As Range, headerTwo As Range
Dim x As Integer
Dim lastCol As Long
Set ShtOne = Sheets("ReportOld")
Set ShtTwo = Sheets("ReportNew")
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
For Each headerTwo In shtTwoHead
For Each headerOne In shtOneHead
If headerTwo.Value = headerOne.Value Then
Else
x = MsgBox("Headers are not matching in both sheets.")
MsgBox "value is:" & headerTwo.Value
Exit Sub
End If
Next headerOne
Next headerTwo
End Sub
Sub new_code()
Dim a As Integer
Dim b As Integer
Dim x As Integer
Dim HeadNew As Integer
Dim HeadOld As Integer
Dim HeadingsNew() As String
Dim HeadingsOld() As String
a = 1
b = 1
HeadNew = 0
HeadOld = 0
Erase HeadingsNew
Erase HeadingsOld
Worksheets("ReportNew").Activate
Do Until Len(Trim(Cells(1, a))) = 0
DoEvents
ReDim Preserve HeadingsNew(1 To a)
HeadingsNew(a) = Trim(Cells(1, a))
a = a + 1
Loop
a = a - 1
HeadNew = a
Worksheets("ReportOld").Activate
Do Until Len(Trim(Cells(1, b))) = 0
DoEvents
ReDim Preserve HeadingsOld(1 To b)
HeadingsOld(b) = Trim(Cells(1, b))
b = b + 1
Loop
b = b - 1
HeadOld = b
x = 1
Do Until x > a
DoEvents
If HeadingsNew(x) <> HeadingsOld(x) Then
MsgBox " Headings are different" & Chr(10) & Chr(10) & _
" column number " & x & Chr(10) & _
" ReportNew: " & (HeadingsNew(x)) & Chr(10) & _
" ReportOld: " & (HeadingsOld(x)), vbCritical, "Data Issue"
End If
x = x + 1
Loop
If HeadOld <> HeadNew Then
MsgBox " The number of headings don't match", vbcritacal, "Data Issue"
End If
End Sub
I suggest a variant array. Here is a simple solution.
Sub Compare()
Dim header1 As Variant, header2 As Variant, i as long
header1 = sheets("ReportOld").Rows(1).Value
header2 = sheets("ReportNew").Rows(1).Value
For i = 1 To 100000
If header1(1, i) <> vbNullString Then
If header1(1, i) <> header2(1, i) Then
MsgBox "Compare Failed at column " & i
Exit For
End If
Else
MsgBox "Compare ="
Exit For
End If
Next i
End Sub

Searching keywords in title

Im using the below code for seacrhing a set of keywords in a cell which has title. While running the code im getting "Run Time error 13" Type mismatch on b = cell.Value line.
Application.ScreenUpdating = False
Dim col As Range, cell1 As Range, a As String, b As String, i As Integer
Set col = Range("KW[KW1]")
Dim target, cell As Range
Sheets("Data").Select
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
Dim term, tag As String
For Each cell1 In col
a = cell1.Value
term = a
tag = a
For Each cell In target
b = cell.Value
' If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
If Module1.ExactWordInString(b, a) Then
For i = 1 To 15
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
Exit For
End If
Next i
End If
Next cell
Next cell1
Application.ScreenUpdating = True
However its running perfectly if we have 1000 tiltes in a column, but i want to run this code for a massive range upto 50,000 to 200,000. Please help me.
Try this, you didn't declare target as a range, might be it.
BTW, when you compare string VBA is case sensitive, so try to use Lcase() if you only want to compare content!
Application.ScreenUpdating = False
Dim target As Range, cell As Range
Dim term As String, tag As String
Dim col As Range, cell1 As Range, a As String, b As String, i As Integer
Sheets("Data").Select
Set col = Range("KW[KW1]")
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
For Each cell1 In col
a = Cstr(cell1.Value)
term = a
tag = a
For Each cell In target
b = Cstr(cell.Value)
'If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
If Module1.ExactWordInString(b, a) Then
For i = 1 To 15
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
Exit For
End If
Next i
End If
Next cell
Next cell1
Application.ScreenUpdating = True