Replace cells containing zero with blank - vba

I have a very large amount of data A4:EW8000+ that I want to replace cells containing a zero with a blank cell. Formatting the cells is not an option as I need to retain the current format. I'm looking for the fastest way to replace zeros with blank cells.
I can do this with looping but its very slow. Below code:
Sub clearzero()
Dim rng As Range
For Each rng In Range("A1:EW10000")
If rng.Value = 0 Then
rng.Value = ""
End If
Next
End Sub
Is there an easy way I can do this without looping?
I tried the below code, but it doesn't seem to work correctly. It hangs Excel for a while (not responding) then it loops through the range and blanks every cell.
Sub RemoveZero()
Dim LastRow As Long
Const StartRow As Long = 2
LastRow = Cells.Find(What:="0", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
With Range("B:EW")
.Value = Range("B:EW").Value
.Replace "0", "0", xlWhole, , False
On Error Resume Next
.SpecialCells(xlConstants).Value = ""
.SpecialCells(xlFormulas).Value = 0
End With
End Sub

This is all the VBA you need to automate the replacements:
[a4:ew10000].Replace 0, "", 1
.
UPDATE
While the above is concise, the following is likely the fastest way possible. It takes less than a quarter of a second on my computer for your entire range:
Sub RemoveZero()
Dim i&, j&, v, r As Range
Set r = [a4:ew10000]
v = r.Value2
For i = 1 To UBound(v, 1)
For j = 1 To UBound(v, 2)
If Len(v(i, j)) Then
If v(i, j) = 0 Then r(i, j) = vbNullString
End If
Next
Next
End Sub

I have found that sometimes it is actually more expedient to cycle through the columns on bulk replace operations like this.
dim c as long
with worksheets("Sheet1")
with .cells(1, 1).currentregion
for c = 1 to .columns.count
with .columns(c)
.replace what:=0, replacement:=vbNullString, lookat:=xlWhole
end with
next c
end with
end with
Splitting the overall scope into several smaller operations can improve overall performance. My own experience with this is on somewhat larger data blocks (e.g. 142 columns × ~250K rows) and replacing NULL from an SQL feed not zeroes but this should help.

Related

Deleting rows with values based on a column

I have a monthly base with almost 373,000 lines. Of these, part has a low value or is blank. I'd like to erase this lines.
I have part of this code to delete those that have zero. How to create a code that joins the empty row conditions (column D) in a more agile way.
Thanks
Sub DelRowsZero()
Dim i As Long
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D") = 0 Then Rows(i).Delete
Next i
End Sub
How about:
Sub ZeroKiller()
Dim N As Long, ToBeKilled As Range
Dim i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If Cells(i, "D").Value = 0 Or Cells(i, "D").Value = "" Then
If ToBeKilled Is Nothing Then
Set ToBeKilled = Cells(i, "D")
Else
Set ToBeKilled = Union(ToBeKilled, Cells(i, "D"))
End If
End If
Next i
If Not ToBeKilled Is Nothing Then
ToBeKilled.EntireRow.Delete
End If
End Sub
This assumes that A is the longest column. If this is not always the case, use:
N = Range("A1").CurrentRegion.Rows.Count
I am concerned about the 375K lines, who knows how long this will take to run.
Sub Button1_Click()
Dim i As Long
For i = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
If Cells(i, "D") = 0 Or Cells(i, "D") = "" Then
Rows(i).Delete
End If
Next i
End Sub
I'm curious to know if this works for others, it just uses the "replace" 0 values to blanks, then uses specialcells to delete the blank rows. My test of 38K rows takes 3 seconds.
Sub FindLoop()
Dim startTime As Single
startTime = Timer
'--------------------------
Columns("D:D").Replace What:="0", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'---------------------------------
Debug.Print Timer - startTime
End Sub
There's apparently an argument to be made, that deleting rows as you find them would be faster than deleting them all at once.
So I ran the below code with 36000 rows of =RANDBETWEEN(0, 10) in columns A and B (and then copy+paste special/values), and it completed thrice in 32 seconds and dusts.
Uncommenting the currentValue assignment and replacing the array subscript accesses with currentValue comparisons adds 2.5 seconds overhead; uncommenting the IsError check adds another 3.5 seconds overhead - but then the code won't blow up if the checked cells have the slightest chance of containing some #REF! or #VALUE! error.
Every time I ran it, ~4000 rows ended up being deleted.
Note:
No implicit ActiveSheet references. The code works against Sheet2, which is the code name for Worksheets("Sheet2") - a globally scoped Worksheet object variable that you get for free for any worksheet that exists at compile-time. If the sheet you're running this against exists at compile-time, use its code name (that's the (Name) property in the Properties toolwindow / F4).
Range is hard-coded. You already know how to get the last row with data, so I didn't bother with that. You'll want to dump your working range in a variant array nonetheless.
The commented-out code can be ignored/deleted if there's no way any of the cells involved have any chance of ever containing a worksheet error value.
Public Sub SpeedyConditionalDelete()
Dim startTime As Single
startTime = Timer
'1. dump the contents into a 2D variant array
Dim contents As Variant
contents = Sheet2.Range("A1:B36000").Value2
'2. declare your to-be-deleted range
Dim target As Range
'3. iterate the array
Dim i As Long
For i = LBound(contents, 1) To UBound(contents, 1)
'4. get the interesting current value
'Dim currentValue As Variant
'currentValue = contents(i, 1)
'5. validate that the value is usable
'If Not IsError(currentValue) Then
'6. determine if that row is up for deletion
If contents(i, 1) = 0 Or contents(i, 1) = vbNullString Then
'7. append to target range
If target Is Nothing Then
Set target = Sheet2.Cells(i, 1)
Else
Set target = Union(target, Sheet2.Cells(i, 1))
End If
End If
'End If
Next
'8. delete the target
If Not target Is Nothing Then target.EntireRow.Delete
'9. output timer
Debug.Print Timer - startTime
End Sub
Of course 375K rows will run much longer than 32-38 seconds, but I can't think of a faster solution.

Applying VBA RIGHT to an entire column - Infinite Loop Issue

I have data that I am working to Parse Out that I have imported from approval emails sent in Outlook. At this point I am just importing the CreationTime and the SubjectLine.
For the subject line I am able to use the Split function to separate out most of the data. I then am left with Job Codes in Column B and Position numbers in Column C which includes the text: "Job Codes: XXXX" and the four digit job code number and "PN XXXX" and either a four digit or 6 digit position number. I am trying to use the Right functionality to loop through the entire column and reformat the column just to show only the four digit job code number for Column B and either just the 4 digit or 6 digit position number (the actual numbers) for Column C
For Job Code Column B:
Currently my code works for Shortening the Job Codes but it involves adding a column, putting the RIGHT formula in that column for the shortened Job Code, then copying and pasting the formula as values back into the column and then deleting the original column.
The problem- Works but perhaps not the most efficient with a larger data set (currently 200 rows but will have 2000 or more)
Code:
Sub ShortenJobCodes()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC3,4)"
Dim oRng As Range
Dim LastRow As Long
Range("B1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set oRng = Range("B:B")
Range(oRng, Cells(LastRow, "B")).FormulaR1C1 = R4Col
Set oRng = Nothing
Columns("B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
For Position Numbers Column C:
Currently I have mirrored the above code but added in an if statement using LEN to count if the characters are less than 8, if so then insert one RIGHT function if not insert the other RIGHT function. This also involves adding an additional column putting the RIGHT formula in that column for the shortened Position Number(Eliminating all but just the number), then copying and pasting the formula as values back into the column and then deleting the original column.
Problem - This works but seems to take forever to process and in fact looks like it is in an infinite loop. When I Esc out of it, it does add the column and then input the proper RIGHT formula (leaving just the numeric values) but the sub never seems to end, nor does it copy and paste the formulas as values or delete the original column. As noted above I realize this is likely a more efficient way to do this but I have tried a bunch of options without any luck.
I am realizing part of the loop might be due to the range itself being an entire column but I cannot find a way to stop that with the last row (even though I have a count in there).
Code:
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC4,4)"
Const R6Col = "=RIGHT(RC4,6)"
Dim oRng As Range
Dim rVal As String
Dim y As Integer
Dim selCol As Range
Dim LastRow As Long
Range("C1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = Range("D:D")
For Each oRng In selCol
oRng.Select
rVal = oRng.Value
If Len(oRng.Value) > 8 Then
oRng.Offset(0, -1).FormulaR1C1 = R6Col
Else
oRng.Offset(0, -1).FormulaR1C1 = R4Col
End If
Next
Set oRng = Nothing
Columns("C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("D1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Major Question: Is there a way to use RIGHT/TRIM/LEN/LEFT functions to do this within a cell without having to add columns/delete columns and insert functions?
There are a few things you can do here to speed up your code. I'm only going to reference the second code block as you can apply similar logic to the first.
The first issue is that you create a LastRow variable but never reference it again. It looks like you meant to use this in the selCol range. You should change that line to Set selCol = Range("C1:C" & lastRow). This way, when you loop through the rows you only loop through the used rows.
Next, in the For-Each loop you Select every cell you loop through. There really isn't any reason to do this and takes substantially longer. You then create the variable rVal but never use it again. A better way to set up the loop is as follows.
For Each oRng in selCol
rVal = oRng.Value
If Len(rVal) > 8 Then
oRng.Value = Right(rVal, 6)
Else
oRng.Value = Right(rVal, 4)
End If
Next
This is much cleaner and no longer requires creating columns or copying and pasting.
Try this, it uses Evaluate and no loops or added columns.
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Dim selCol As Range
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = .Range(.Cells(1, 3), .Cells(LastRow, 3))
selCol.Value = .Evaluate("INDEX(IF(LEN(" & selCol.Address(0, 0) & ")>8,RIGHT(" & selCol.Address(0, 0) & ",6),RIGHT(" & selCol.Address(0, 0) & ",4)),)")
End With
Application.ScreenUpdating = True
End Sub
Or work with arrays
Sub ShortenPositionNumbers()
Dim data As Variant
Dim i As Long
With Range("C3:C" & Cells(Rows.Count, "A").End(xlUp).Row)
data = Application.Transpose(.Value)
For i = LBound(data) to UBound(data)
If Len(data(i)) > 8 Then
data(i) = RIGHT(data(i),6)
Else
data(i) = RIGHT(data(i),4)
End If
Next
.Value = Application.Transpose(data)
End With
End Sub

excel vba fill column from 1 to N

I am trying to write a VBA code to autofill range A1:A10000 with numbers 1 to 10000 but without entering 1 in A1 and 2 in A2 to create a range.
Basically, I need a code that looks like this:
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
(1,2).AutoFill Destination:=fillRange
Of course this does not work, but you get what it.
Writing and reading to/from the worksheet are some of the slowest actions you can perform. Writing time-efficient code means doing as much in memory as you can.
Try writing all your values into an array, then writing the whole thing to the worksheet in one shot, something like this:
Sub printRange(total As Integer)
Dim i, myRange() As Integer
ReDim myRange(1 To total)
For i = 1 To total:
myRange(i) = i
Next i
'Use Transpose to shift the 1d array into a column
Worksheets("Sheet1").Range("A1:A" & UBound(myRange)).Value = _
Application.WorksheetFunction.Transpose(myRange)
End Sub
For total = 10000, this pretty much runs instantly, even on a ten year old dinosaur desktop.
Dim fillRange As Range
Dim i As Long
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
With fillRange
For i = .Cells(1, 1).Row To .Cells(.Rows.Count, 1).Row
.Cells(i, 1).Value = i
Next i
End With 'fillRange
Or with AutoFill :
With Worksheets("Sheet1")
Range("A1").Value = 1
Range("A2").Value = 2
Range("A1:A2").AutoFill Destination:=Range("A1:A10000")
End With 'Worksheets("Sheet1")
this should be fast enough
you could use the following function
Function FillNumbers(rng As Range) As Variant
Dim i As Long
ReDim nmbrs(1 To rng.Rows.Count)
For i = 1 To UBound(nmbrs)
nmbrs(i) = i
Next
FillNumbers = Application.Transpose(nmbrs)
End Function
in the following manner
With Worksheets("Sheet1").Range("A1:A10000")
.Value = FillNumbers(.Cells)
End With
Can't you use a simple loop?
For i = 1 to 10000
Worksheets("Sheet1").Cells(i, 1) = i
Next i
Dim fillRagne As Range
Set fillRange = Range(Cells(1, 1), Cells(1000, 1))
For Each cell in fillRange
cell.value = cell.Row
Next cell

VBA: copying the first empty cell in the same row

I am a new user of VBA and am trying to do the following (I got stuck towards the end):
I need to locate the first empty cell across every row from column C to P (3 to 16), take this value, and paste it in the column B of the same row.
What I try to do was:
Find non-empty cells in column C, copy those values into column B.
Then search for empty cells in column B, and try to copy the first non-empty cell in that row.
The first part worked out fine, but I am not too sure how to copy the first non-empty cell in the same row. I think if this can be done, I might not need the first step. Would appreciate any advice/help on this. There is the code:
Private Sub Test()
For j = 3 To 16
For i = 2 To 186313
If Not IsEmpty(Cells(i, j)) Then
Cells(i, j - 1) = Cells(i, j)
End If
sourceCol = 2
'column b has a value of 2
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell, copy the first not empty value in that row
For currentRow = 1 To RowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If Not IsEmpty(Cells(i, 3)) Or Not IsEmpty(Cells(i, 4)) Or Not IsEmpty(Cells(i, 5)) Or Not IsEmpty(Cells(i, 6)) Then
Paste
~ got stuck here
Next i
Next j
End Sub
Your loop is really inefficient as it is iterating over millions of cells, most of which don't need looked at. (16-3)*(186313-2)=2,422,043.
I also don't recommend using xlUp or xlDown or xlCellTypeLastCell as these don't always return the results you expect as the meta-data for these cells are created when the file is saved, so any changes you make after the file is saved but before it is re-saved can give you the wrong cells. This can make debugging a nightmare. Instead, I recommend using the Find() method to find the last cell. This is fast and reliable.
Here is how I would probably do it. I'm looping over the minimum amount of cells I can here, which will speed things up.
You may also want to disable the screenupdating property of the application to speed things up and make the whole thing appear more seemless.
Lastly, if you're new to VBA it's good to get in the habit of disabling the enableevents property as well so if you currently have, or add in the future, any event listeners you will not trigger the procedures associated with them to run unnecessarily or even undesirably.
Option Explicit
Private Sub Test()
Dim LastUsed As Range
Dim PasteHere As Range
Dim i As Integer
Application.ScreenUpdating=False
Application.EnableEvents=False
With Range("B:B")
Set PasteHere = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If PasteHere Is Nothing Then Set PasteHere = .Cells(1, 1) Else: Set PasteHere = PasteHere.Offset(1)
End With
For i = 3 To 16
Set LastUsed = Cells(1, i).EntireColumn.Find("*", Cells(1, i), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If Not LastUsed Is Nothing Then
LastUsed.Copy Destination:=PasteHere
Set PasteHere = PasteHere.Offset(1)
End If
Set LastUsed = Nothing
Next
Application.ScreenUpdating=True
Application.EnableEvents=True
End Sub
Sub non_empty()
Dim lstrow As Long
Dim i As Long
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
lstrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 1 To lstrow
If IsEmpty(Range("B" & i)) Then
Range("B" & i).Value = Range("B" & i).End(xlToRight).Value
End If
Next i
End Sub

Is there a faster CountIF

As the title says. Is there any function or VBA code which does the same function as a countif and is a lot faster. Currently in the middle of massive countif and it is just eating up my CPU.
It is just a basic countif inside the worksheet. Not in VBA.
=countif(X:X,Y) However the lists are massive. So both lists are around 100,000~ rows
If you can do without a count of the occurances and simply wish to check if the value x exists in the column of y's, then returning a boolean TRUE or FALSE with the ISNUMBER function evaluating a MATCH function lookup will greatly speed up the process.
=ISNUMBER(MATCH(S1, Y:Y, 0))
Fill down as necessary to catch all returns. Sort and/or filter the returned values to tabulate results.
Addendum:
Apparently there is. The huge improvement in the MATCH function calculation times over the COUNTIF function made me wonder if MATCH couldn't be put into a loop, advancing the first cell in its lookup_array parameter to the previously returned row number plus one until there were no more matches. Additionally, subsequent MATCh calls to lookup the same number (increasing the count) could be made to increasingly smaller lookup_array cell ranges by resizing (shrinking) the height of the column by the returned row number as well. If the processed values and their counts were stored as keys and items in a scripting dictionary, duplicate values could be instantly resolved without processing a count.
Sub formula_countif_test()
Dim tmr As Double
appOFF
tmr = Timer
With Sheet2.Cells(1, 1).CurrentRegion
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
.Cells(1, 3).Resize(.Rows.Count, 1).FormulaR1C1 = _
"=countif(c1, rc2)" 'no need for calculate when blocking in formulas like this
End With
End With
Debug.Print "COUNTIF formula: " & Timer - tmr
appON
End Sub
Sub formula_match_test()
Dim rw As Long, mrw As Long, tmr As Double, vKEY As Variant
'the following requires Tools, References, Microsoft Scripting Dictionary
Dim dVALs As New Scripting.dictionary
dVALs.CompareMode = vbBinaryCompare 'vbtextcompare for non-case sensitive
appOFF
tmr = Timer
With Sheet2.Cells(1, 1).CurrentRegion
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
For rw = 1 To .Rows.Count
vKEY = .Cells(rw, 2).Value2
If Not dVALs.Exists(vKEY) Then
dVALs.Add Key:=vKEY, _
Item:=Abs(IsNumeric(Application.Match(vKEY, .Columns(1), 0)))
If CBool(dVALs.Item(vKEY)) Then
mrw = 0: dVALs.Item(vKEY) = 0
Do While IsNumeric(Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0))
mrw = mrw + Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0)
dVALs.Item(vKEY) = CLng(dVALs.Item(vKEY)) + 1
Loop
End If
.Cells(rw, 3) = CLng(dVALs.Item(vKEY))
Else
.Cells(rw, 3) = CLng(dVALs.Item(vKEY))
End If
Next rw
End With
End With
Debug.Print "MATCH formula: " & Timer - tmr
dVALs.RemoveAll: Set dVALs = Nothing
appON
End Sub
Sub appON(Optional ws As Worksheet)
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub appOFF(Optional ws As Worksheet)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub
        
I used 10K rows with columns A and B filled by RANDBETWEEN(1, 999) then copied and pasted as values.
Elapsed times: 
    Test 1¹ - 10K rows × 2 columns filled with RANDBETWEEN(1, 999)
        COUNTIF formula:           15.488 seconds
        MATCH formula:                1.592 seconds  
    Test 2² - 10K rows × 2 columns filled with RANDBETWEEN(1, 99999)
        COUNTIF formula:           14.722 seconds
        MATCH formula:                3.484 seconds  
I also copied the values from the COUNTIF formula into another column and compared them to the ones returned by the coded MATCH function. They were identical across the 10K rows. 
   ¹ More multiples; less zero counts 
   ² More zero counts, less multiples 
While the nature of the data clearly makes a significant difference, the coded MATCH function outperformed the native COUNTIF worksheet function every time.
Don't forget the VBE's Tools ► References ► Microsoft Scripting Dictionary.
I use the following technique in place of COUNTIF. I have 115k rows of data and the calculation step was basically instantaneous, but you spend a bit more time setting it up.
Make a copy of the data you want to count and put in column A of a new sheet.
Sort the data you want to count (such that all identical items are next to each other).
Put the following formula in column B =IF(A2=A1,B2+1,1). Populate the column with the formula then paste value.
Put a sequential number in column C (just 1,2,3,4 ... up to the number of rows you have)
Sort everything by column C descending. The result is that in column B, the biggest count comes first.
Select column A and B, then use "Remove Duplicate" function. Now you're left with one entry per distinct row of Data and the biggest count for each.
Back in your real data sheet, use =VLOOKUP(A2,Sheet2!A:B,2,false) to get the count.
If you want to make a macro out of this, simply use Record Macro while performing the above actions.
Try sumproduct(countif(x:x,y:y))
It’s slightly faster but by how much I am not sure.
Also let us know if you have found a better option out there.
There is an easy workaround for COUNTIF, after sorting the data. You may add this to your VB Script, and run. For data with around 1 lakh line items, normal COUNTIF takes almost 10-15 mins. This script will get the counts in <10 secs.
Sub alternateFunctionForCountIF()
Dim DS As Worksheet
Set DS = ThisWorkbook.ActiveSheet
Dim lcol As Integer
lcol = DS.Cells(1, Columns.Count).End(xlToLeft).Column
Dim fieldHeader As String
Dim lrow As Long, i As Long, j As Long
Dim countifCol As Integer, fieldCol As Integer
fieldHeader = InputBox("Enter the column header to apply COUNTIF")
If Len(fieldHeader) = 0 Then
MsgBox ("Invalid input. " & Chr(13) & "Please enter the column header text and try again")
Exit Sub
End If
For i = 1 To lcol
If fieldHeader = DS.Cells(1, i).Value Then
fieldCol = i
Exit For
End If
Next i
If fieldCol = 0 Then
MsgBox (fieldHeader & " could not be found among the headers. Please enter a valid column header")
Exit Sub
End If
countifCol = fieldCol + 1
lrow = DS.Cells(Rows.Count, "A").End(xlUp).Row
DS.Range(DS.Cells(1, countifCol).EntireColumn, DS.Cells(1, countifCol).EntireColumn).Insert
DS.Cells(1, countifCol) = fieldHeader & "_count"
DS.Sort.SortFields.Clear
DS.Sort.SortFields.Add Key:=Range(DS.Cells(2, fieldCol), DS.Cells(lrow, fieldCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DS.Sort
.SetRange Range(DS.Cells(1, 1), DS.Cells(lrow, lcol))
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim startPos As Long, endPos As Long
Dim checkText As String
For i = 2 To lrow
checkText = LCase(CStr(DS.Cells(i, fieldCol).Value))
If (checkText <> LCase(CStr(DS.Cells(i - 1, fieldCol).Value))) Then
startPos = i
End If
If (checkText <> LCase(CStr(DS.Cells(i + 1, fieldCol).Value))) Then
endPos = i
For j = startPos To endPos
DS.Cells(j, countifCol) = endPos - startPos + 1
Next j
End If
Next i
MsgBox ("Done")
End Sub