find row number of cell that contains criteria - excel

I'm needing to find the first row numbers of cell in column C that contains "120" without duplicates (data I have has more than 10 of each number code, I only need the first one). So the code should pick up the first row number containing e.g. 120, 7120, 81200.
The code I've tried below have only managed to find the first row number with cell that contained 120. For reference, AGCL is a column letter derived from another find function and tbAC is a user input into a textbox.
Dim AGCN As Long
Dim AGCL As String
Dim AGNN As Long
Dim AGNL As String
Dim i As Long
Dim RowD As Long
Dim AAC As String
Dim rng As Range
Dim rownumber As Long
Dim AGC As Range
Dim AGN As Range
Dim firstaddress As Long
Dim nextaddress As Long
Set rng = Sheet1.Columns(AGCL & ":" & AGCL).Find(what:="*" & tbAC & "*",
LookIn:=xlValues, lookat:=xlPart)
rownumber = rng.Row
Debug.Print rownumber '9
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Value
Debug.Print firstaddress
With Me.ListBox2
.ColumnCount = 3
.ColumnWidths = "50;150;70"
.AddItem
.List(i, 0) = Str(firstaddress)
i = o + 1
End With
Do
Set c = .FindNext(c)
If c Is Nothing Then
GoTo donefinding
ElseIf firstaddress <> c.Value Then
nextaddress = c.Value
Debug.Print nextaddress 'it doesn't print any value here
'With Me.ListBox2
' .ColumnCount = 3
' .ColumnWidths = "50;150;70"
' .AddItem
' .List(i, 0) = Str(nextaddress)
' Debug.Print nextaddress
' i = o + 1
'End With
End If
Loop While c.Address <> firstaddress
End If
donefinding: Exit Sub
End With
Any help would be greatly appreciated, thank you!

Here is the Range.FindNext Function you can use to retrieve all the cells having 120.
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
If c is Nothing Then
GoTo DoneFinding
Elseif not firstaddress.value = c.value
''Whatever you want to do with the Second Found Value
debug.print c.value
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Now to check that the value already found or not, you can play in the If Condition of this loop. So that you don't get the same values again.

UPDATED: Okay I updated one last time. As mentioned, I don't know what you want to do with the extra values... but this function will output them where ever...?
good luck.
Here's a custom function that matches what you're looking for, it will return the first time that 120 appears in a cell...
Here's one more that you could use if you truly wanted "contains" only a partial match.
Function SuperSearcherTHING(ivalue As Variant, theColumn As Range) As String
Dim rCell As Range
Const theSPACER As String = "|"
For Each rCell In Intersect(theColumn.EntireColumn, theColumn.Worksheet.UsedRange).Cells
If InStr(1, rCell.Value, ivalue, vbTextCompare) > 0 Then
SuperSearcherTHING = rCell.Value & theSPACER & SuperSearcherTHING
End If
Next rCell
SuperSearcherTHING = Left(SuperSearcherTHING, Len(SuperSearcherTHING) - Len(theSPACER))
End Function

Related

Change the values in a column depending upon different criteria

I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub

Find list of words from a range if words exits multiple times

I have a list of words in Sheet1 I need to match one by one from Sheets("Sheet2").Range("A1:A7500") until the end of the Range. Whenever word is matched I need to do something with it in Sheet1. That word occurs multiple times in Sheets("Sheet2").Range("A1:A7500").
Following code is Finding word only once. I dont understand where it is going wrong.
Sub XMAX()
Dim lrow As Long
Dim cel As Range
Dim oRng As Range: Set oRng = Sheets("Sheet2").Range("A1:A7500")
Dim oFoundRng As Range, oLastRng As Range
lrow = Sheets("sheet1").Cells(Sheets("Sheet1").Rows.Count, "f").End(xlUp).Row
'''''''''''''''Sheet1'''''''''''''''
For Each cel In Range("f4:f" & lrow)
If IsEmpty(cel.Value) = False Then
Set oFoundRng = oRng.find(cel.Value)
Do While Not oFoundRng Is Nothing
If UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("X" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "YO" Then
Range("V" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "JAN" Then
Range("U" & cel.Row).Value = "X"
Else
MsgBox oFoundRng.Value
End If
Set oLastRng = oFoundRng
Set oFoundRng = oRng.FindNext(cel.Value) 'Getting Error(1004) here "unable to get findnext property of the range class"
If oLastRng >= oFoundRng Then
Exit Do
End If
Loop
Else
End If
Next
Change this line
Set oFoundRng = oRng.FindNext(oFoundRng)
to
Set oFoundRng = oRng.FindNext
You are not searching for the word but for the range you previously found. You actually don't need to pass a value to .FindNext at all.
You also have to change this line
If oLastRng >= oFoundRng Then
to
If oLastRng.Row >= oFoundRng.Row Then
since the first line compares the values (which is not what you want to do since it will always evaluate to True). You actually want to compare the row numbers.
On another note, the following code snippet does not work:
If UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("X" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("W" & cel.Row).Value = "X"
This ElseIf will never be triggered since the condition is the same as the initial If condition.
You also don't need both of these statements:
Set oFoundRng = Nothing
Exit Do
They both achieve the same thing (breaking the loop), Exit Do does it more efficiently.
you may be after this (explanations in comments):
Sub XMAX()
Dim cel As Range
Dim oRng As Range: Set oRng = Sheets("Sheet2").Range("A1:A7500")
Dim oFoundRng As Range
Dim firstAddress As String
With Sheets("sheet1") ' reference "Sheet1" sheet
With .Range("f4", .Cells(.Rows.Count, "f").End(xlUp)) ' reference referenced sheet column "F" range from row 4 down to last not empty one
If WorksheetFunction.CountA(.Cells) > 0 Then ' if there's at least one not empty cell
For Each cel In .SpecialCells(xlCellTypeConstants) ' loop through referenced range not empty cells
Set oFoundRng = oRng.Find(what:=cel.Value, LookIn:=xlValues, lookat:=xlWhole) ' always specify at least 'LookIn' and 'LookAt' parameters, or they will be set as per last 'Find()' usage (even from Excel UI!)
If Not oFoundRng Is Nothing Then ' if a match found
firstAddress = oFoundRng.Address ' store first matched cell address
Do
Select Case UCase(oFoundRng.Offset(0, 1).Value2)
Case "ISAAC"
.Range("X" & cel.Row).Value = "X"
Case "YO"
.Range("V" & cel.Row).Value = "X"
Case "JAN"
.Range("U" & cel.Row).Value = "X"
Case Else
MsgBox oFoundRng.Value
End Select
Set oFoundRng = oRng.FindNext(oFoundRng) ' search for next occurrence
Loop While oFoundRng.Address <> firstAddress ' exit do when hitting fisr found cell again
End If
Next
End If
End With
End With
End Sub

VBA copy a found value

I am fairly new to VBA . I have been trying to get this code working to no avail, basically I have a search to find a value (That part is working) and I want to copy that value and the row where this value is located into another sheet on the next empty row and date stamp it. Any help will be appreciated. Many Thanks.
This a sample of the table:
Sample Table
This is the code I have half working:
Sub FindingValues()
Dim val As String
Dim result As String
Dim firstAddress As String
Dim c As Range
val = InputBox("Enter ID")
Set c = Sheets("Sheet1").Range("E:E").Find(val, LookIn:=xlValues, _
MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
' Application.Goto c
Copy.Sheets(Sheet2).c
Set c = Cells.FindNext(c)
Else
If c Is Nothing Then
MsgBox "Could Not Find " & Res
End If
End If
I think this should do it...
Sub FindingValues()
Dim val As String, result As String, firstAddress As String, entryROW As Long
Dim c As Range
'PGCodeRider making assumption to inser in column A
Dim columnNumberToPasteData As Long
columnNumberToPasteData = 1
'assumes Sheet2 is where data should be copied
Dim WS2 As Worksheet
Set WS2 = Sheets("Sheet2")
val = InputBox("Enter ID")
'probably want something like this so that if user wants to cancel
If val = "" Then Exit Sub
Set c = Sheets("Sheet1").Range("E:E").Find(val, LookIn:=xlValues, _
MatchCase:=False)
If Not c Is Nothing Then
entryROW = WS2.Cells(Rows.Count, columnNumberToPasteData).End(xlUp).Row + 1
WS2.Rows(entryROW).Value = c.Worksheet.Rows(c.Row).Value
WS2.Cells(entryROW, Columns.Count).End(xlToLeft).Offset(0, 1).Value = VBA.Now
' With WS2.Cells(entryROW, columnNumberToPasteData)
' .Offset(0, 0).Value = c.Value
' .Offset(0, 1).Value = c.Row
' .Offset(0, 2).Value = Now()
' End With
'
Else
If c Is Nothing Then MsgBox "Could Not Find " & val
End If
End Sub

Excel VBA loop through listbox

I have this code that I am using to search a range when I click the item in my listbox. I have never looped through a listbox and want to know how I add a loop to perform what I need without clicking each item in the listbox. Here is the code I am using:
Sub FindListValue()
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Dim c As Range
With Sheets("PN-BINS")
Set rSearch = .Range("B1", .Range("B65536").End(xlUp))
End With
Dim i As Long
' loop through all items in ListBox1
For i = 0 To Me.ListBox1.ListCount - 1
' current string to search for
strFind = Me.ListBox1.List(i)
With rSearch
Set c = .Find(strFind, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then 'found it
c.Select
Me.ListBox1.AddItem strFind & " | " & c.Offset(0, -1).Value, Me.ListBox1.ListIndex + 1
Me.ListBox1.RemoveItem (Me.ListBox1.ListIndex)
'Exit Sub
Else: 'MsgBox strFind & " is not listed!" 'search failed
End If
End With
' the rest of your code logics goes here...
Next i
End Sub
In order to loop through all items in the ListBox1, use the following loop:
Dim i As Long
' loop through all items in ListBox1
For i = 0 To Me.ListBox1.ListCount - 1
' current string to search for
strFind = Me.ListBox1.List(i)
' the rest of your code logics goes here...
Next i
B.T.W , it's better if you define your rSearch range in the following way (without using Activate and ActiveSheet)
With Sheets("PN-BINS")
Set rSearch = .Range("B1", .Range("B65536").End(xlUp))
End With
Edit 1: Whole code
Sub FindListValue()
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Dim c As Range
Dim i As Long
With Sheets("PN-BINS")
Set rSearch = .Range("B1", .Range("B65536").End(xlUp))
End With
' loop through all items in ListBox1
For i = 0 To Me.ListBox1.ListCount - 1
strFind = Me.ListBox1.List(i) ' string to look for
Set c = rSearch.Find(strFind, LookIn:=xlValues, LookAt:=xlWhole)
' current ListBox1 item is found
If Not c Is Nothing Then
Me.ListBox1.AddItem strFind & " | " & c.Offset(0, -1).Value, i + 1
Me.ListBox1.RemoveItem (i)
' ****** not sure if you want to use the line below ? ******
Exit Sub
Else
MsgBox strFind & " is not listed!" 'search failed
End If
Next i
End Sub

Select dynamic cells based on content number format

I would need some help on the following excel 2010 vba:
I would like to select all cells which contain a specific number format. The cells can be located anywhere in column A.
Any ideas are welcome.
Thank you in advance!
This code:
Dim Tmp As String
Tmp = ""
For Each xx In Range("A1:A1000")
If (xx.NumberFormat = "0") Then
Tmp = Tmp & "," & xx.Address
End If
Next
Tmp = Mid(Tmp, 2)
Range(Tmp).Select
select all the cells that have NumberFormat "0" ... Substitute the if stantement in base of your request.
Here is a way using the Range.Find method
Option Explicit
Sub CellsWithNumberFormat()
Dim R As Range, C As Range
Const sFmt As String = "0.00" '<-- set to whatever numberformat you want
Dim colAddr As Collection
Dim sFirstAddress As String
Dim I As Long
Dim sTemp As String
Set R = Cells.Columns(1)
With Application.FindFormat
.NumberFormat = sFmt
End With
Set colAddr = New Collection
With R
Set C = .Find(what:="", LookIn:=xlValues, searchformat:=True)
If Not C Is Nothing Then
colAddr.Add Item:=C.Address
sFirstAddress = C.Address
Do
Set C = .Find(what:="", after:=C, searchformat:=True)
If C.Address <> sFirstAddress Then
colAddr.Add Item:=C.Address
End If
Loop Until sFirstAddress = C.Address
End If
End With
For I = 1 To colAddr.Count
sTemp = sTemp & "," & colAddr(I)
Next I
sTemp = Mid(sTemp, 2)
Range(sTemp).Select
End Sub

Resources