I want to read through multiple cells in a row and depending if they are all formatted green, turn a separate cell green.
If one cell in the row is either red or has no colour the cell will remain with red or no colour, then loop through my table to read each row and return a format in one column of cells.
And when I click my update button which brings new data into the table, the column of cells will reset to no colour then be formatted.
[![enter image description here][1]][1]
Sub CS_Click()
Range("D6:D37").Interior.ColorIndex = 0
Dim Range1 As Range
Dim Range2 As Range
For RR = 1 To 33
For CC = 1 To 31
Set Range1 = Cells(RR + 5, CC + 6)
Set Range2 = Cells(RR + 5, CC + 3)
If Range1.Interior.ColorIndex = 0 Then
Range2.Interior.ColorIndex = 0
ElseIf Range1.Interior.ColorIndex = 38 Then
Range2.Interior.ColorIndex = 38
ElseIf Range1.Interior.ColorIndex = 50 Then
Range2.Interior.ColorIndex = 50
End If
Next
Next
End Sub
I think you could use something like the following. This will loop through a range and test each row in the range for the ColorIndex of that row. It will then update a destination row with the ColorIndex of your choice
Sub CS_Click()
Dim rng As Range, RowRng As Range
Dim c As Range
Dim RowNo As Long
Dim ClrIndex As Long
Dim ChangeClr As Boolean
' The range of your source data
Set rng = ActiveSheet.Range("G6:AM37")
For Each c In rng.Columns(1).Cells
ClrIndex = -4142
ChangeClr = False
RowNo = c.Row - rng.Cells(1).Row + 1
On Error Resume Next
Set RowRng = Nothing
Set RowRng = rng.Rows(RowNo).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not RowRng Is Nothing Then
Select Case RowRng.Interior.ColorIndex
' Case 50
Case 50
ClrIndex = 50
ChangeClr = True
' Blank rows
Case -4142
ChangeClr = False
' Others not defined, Null (Mixed color rows) and color 38 rows
Case Else:
ClrIndex = 38
ChangeClr = True
End Select
If ChangeClr = True Then
' Update the 'rng.Coloumns.Count + 1' with the offset of your destination cell
c.Offset(0, -3).Interior.ColorIndex = ClrIndex
End If
End If
Next c
End Sub
I think your code can be simplified to:
Sub CS_Click()
Range("D6:D37").Interior.ColorIndex = 0
For RR = 1 To 33
Set Range2 = Cells(RR + 5, 4)
For CC = 1 To 31
Set Range1 = Cells(RR + 5, CC + 6)
c = Range1.Interior.ColorIndex
If c = 38 Or c = 50 Then
Range2.Interior.ColorIndex = c
Exit For ' remove this line as necessary
End If
Next
Next
End Sub
If you leave the Exit For line in, then the colour in column D will change based on the first pink or green cell it gets to. If you remove it, it will change the colour on each pink or green cell - resulting in column D representing the last green or pink colour it detected.
Related
I have a spreadsheet that I'm trying to migrate into SQL.
The spreadsheet contains 65k rows of information over two worksheets.
The people operating the spreadsheet have been colouring the font in the rows either red, blue or yellow depending on the status of the record. Each row is a record with personal data etc. so I can't share online.
As part of the migration to SQL I need to add a column with a status field. The status field on each row should contain either 1, 2, 3, or 4 depending on whether the row has a black, red, blue or yellow font.
Based on searching here I believe it might be possible with a VBA function and a formula?
Could anyone help with what to do? I'm ok with Excel but not a power user by any means.
try using something like this in VBA. You will need to add several more ifs based on the colors you have.
CurrentSheetText="Sheet1"
LastRow = Sheets(CurrentSheetText).Cells.SpecialCells(xlCellTypeLastCell).Row
for iter = 1 to LastRow
if Sheets(CurrentSheetText).Cells(iter, 1).Interior.Color = RGB(255, 255, 0) Then
Sheets(CurrentSheetText).Cells(iter,5).value =1
End if
Next iter
This is very easily implemented with VBA. Due to the lack of information in the post, I can only write you a crude script
Sub AddCol()
Dim wb As Workbook
Dim ws As Worksheet
Dim LRow As Long, i As Long
'Target workbook
Set wb = Workbooks("NAME")
'Target worksheet
Set ws = wb.Sheets(INDEX)
'Target column
target_col = 1
'Output column
output_col = 10
With ws
'Find last row in sheet based on column A
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through row 1 through LRow
For i = 1 To LRow
'populate output col based on target col's font colour
If .Cells(i, target_col).Font.Color = vbBlack Then
.Cells(i, output_col).Value = 1
ElseIf .Cells(i, target_col).Font.Color = vbRed Then
.Cells(i, output_col).Value = 2
ElseIf .Cells(i, target_col).Font.Color = vbBlue Then
.Cells(i, output_col).Value = 3
ElseIf .Cells(i, target_col).Font.Color = vbYellow Then
.Cells(i, output_col).Value = 4
End If
Next i
End With
End Sub
Many thanks for all the help!
It seems there is a very simple way to do this without any code!
I was able to use the filter function by highlighting the cheet and sorting by colour. Once I had all the red text together I was able to just add a 1 to each row and fill down.
Try the next function, please. It will return an array with the settled codes for analyzed colors. It take in consideration all standard nuances (especially for blue) of the colors in discussion:
Function colorNo(sh As Worksheet) As Variant
Dim lastR As Long, cel As Range, arr, k As Long
lastR = sh.Range("A" & rows.count).End(xlUp).row
ReDim arr(lastR - 2)
For Each cel In sh.Range("A2:A" & lastR)
Select Case cel.Font.Color
Case vbRed, 49407: arr(k) = 2: k = k + 1
Case vbBlue, 12611584, 6567712, 9851952, 14395790: arr(k) = 3: k = k + 1
Case vbYellow: arr(k) = 4: k = k + 1
Case Else: arr(k) = 1: k = k + 1
End Select
Next
colorNo = arr
End Function
The above code considers all other colors like being Black!
If in the future you will need some other colors, you should fill appropriate Case newColor lines...
It can be tested/used in this way:
Sub testColorNo()
Dim sh As Worksheet, arrCol As Variant
Set sh = ActiveSheet
arrCol = colorNo(sh)
'the array can be used like it is
'or its value can be dropped in the last empty column
'un comment the next line if you want to visually see the returned array
'but only on testing small range. Otherwise, it will be a huge string...
'Debug.Print Join(arrCol, ","): you can see the array content in Immediate Window
sh.cells(2, sh.UsedRange.Columns.count + 1).Resize(UBound(arrCol) + 1, 1).Value = _
WorksheetFunction.Transpose(arrCol)
End Sub
This should work:
Sub SubColor()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Checking font's color.
Select Case RngTarget.Font.Color
'In Case is black.
Case Is = 0
RngFirstAnswer.Offset(DblRow, 0) = 0
'In case is red.
Case Is = 255
RngFirstAnswer.Offset(DblRow, 0) = 1
'In case is blue.
Case Is = 12611584
RngFirstAnswer.Offset(DblRow, 0) = 2
'In case is yellow.
Case Is = 65535
RngFirstAnswer.Offset(DblRow, 0) = 3
'In other cases.
Case Else
RngFirstAnswer.Offset(DblRow, 0) = "Unclassified"
End Select
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Edit the variables accordingly.
If you need to know what number refers to each of the fonts' color you have, use this:
Sub SubFontColourNumber()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Reporting the font's color.
RngFirstAnswer.Offset(DblRow, 0) = RngTarget.Font.Color
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Like before, edit the variables accordingly.
I have Excel two sheets
data like these....
sheet1: 2000, 3000, 4500, 300, 2000, 3000
sheet 2: 300, 2000, 3000, 4550
i run the following code to highlight the values in both sheets with different colors, where value meets with criteria.
but problem is values of sheet1 all 2000, 3000 filled with colors, whereas sheet2 having 2000, 3000 only one time.
if compare with sheet 2 it contains values 2000, 3000 only one time
so sheet1 values first and second fill with colors, rest of values (last two values) should not be in color.
great thanks for solution.
Sub Dupranges()
Dim wr1 As Range, wr2 As Range, Rng1 As Range, Rng2 As Range
Set wr1 = Worksheets("Sheet1").Range("f1:f10")
Set wr2 = Worksheets("Sheet2").Range("g1:g10")
For Each Rng1 In wr1
Rng1.Value = Rng1.Value
For Each Rng2 In wr2
If Rng1.Value = Rng2.Value Then
Rng1.Interior.ColorIndex = 43
Rng2.Interior.ColorIndex = 33
Exit For
End If
Next
Next
MsgBox "Successfully completed"
End Sub
i think i got what you wanted, its not pretty but i have just started the vba.
You have to change the range back to yours
Sub format()
Dim wr1 As Range, wr2 As Range
Set wr1 = Worksheets("Sheet1").Range("a1:a10")
Set wr2 = Worksheets("Sheet2").Range("a1:a10")
For i = 1 To wr1.Count
check_value = wr1.Item(i)
For k = 1 To wr2.Count
check_value2 = wr2.Item(k)
If (check_value = check_value2) And (wr2.Item(k).Interior.ColorIndex = 33) And
(wr1.Item(i).Interior.ColorIndex = 43) Then
Else
If (check_value = check_value2) And (wr2.Item(k).Interior.ColorIndex <> 33) And
(wr1.Item(i).Interior.ColorIndex <> 43) And (wr2.Item(k).Value > "") Then
wr1.Item(i).Interior.ColorIndex = 43
wr2.Item(k).Interior.ColorIndex = 33
Exit For
End If
End If
Next
Next
MsgBox "Successfully completed"
End Sub
Hopefully you find this usefully
Your code is nearly ok, but you can save time moving ranges to arrays.
Option Explicit
Sub showDupes(src As Range, tgt As Range)
Dim c As Range, i As Long, srcVal
Dim a As Variant, found As Boolean
a = tgt.Value2 'store tgt into array for speed
For Each c In src
srcVal = c.Value2
found = False
For i = 1 To UBound(a)
If a(i, 1) = srcVal Then
found = True
Exit For
End If
Next i
If found Then
'highlight in src
c.Interior.ColorIndex = 43
'highlight in tgt
tgt.Cells(i, 1).Interior.ColorIndex = 43
End If
Next c
End Sub
Sub showDupes_test()
showDupes Sheet1.Range("B4").CurrentRegion, Sheet2.Range("b4").CurrentRegion
End Sub
Note that in this version, if tgt has local duplicates, only the first one will be highlighted.
This is my first post and I'm kind of a beginner; please be gentle. See this link for a reference of the sheet I'm working with.
My plan is to have B2 contain a drop-down list that will be used to selectively collapse certain row groups to just their heading. I've figured out how to collapse one group with this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Range("B1") = "All" Then
Rows("3:6").Select
Selection.EntireRow.Hidden = False
Range("B1").Select
Else
Rows("3:6").Select
Selection.EntireRow.Hidden = True
Range("B1").Select
End If
End If
End Sub
What I don't have is a way to automatically find the groups. If I use a range like Rows("3:6") and someone adds/removes a row, it won't work. (right?)
What I think I need is a way to identify the required ranges by looking at information in the headers. The reference example is blank, but at the "A" column of each grey row will be a number (100, 101, 150, 380, 420A, 420B, 420C, 890). No number will appear twice, and they will appear in numerical order. The "A" column in the white cells under the gray headers will all be blank.
Is there VBA code that will find the locations of the unique headers so I can use their locations to collapse specific groups?
Additional edit to add new screenshots of what I'm hoping to achieve. Person X, Y, Z all have their predetermined grouping they want expanded or collapsed. And I'd probably add an "all" and "none" if I can figure it out. They'll give me that in advance. The numbers on the left won't ever change. It's only a question of whether Person X wants group 120 expanded or collapsed. https://imgur.com/c2lNujn
Edit to show current code:
Public HeaderColor As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.HeaderColor = RGB(217, 217, 217)
'If A1 is true, group rows
If Range("A1").Value Then
'Use getRegion function on target
Dim rng As Range
Set rng = getRegion(Target)
'If the returned range is nothing then end sub
If rng Is Nothing Then Exit Sub
'Select region
Application.EnableEvents = False
rng.Select
Application.EnableEvents = True
End If
'If D1 is true, apply Y/N options for selection in C1
If Range("D1").Value Then
Dim rngX As Range, c As Range
Set rngX = Worksheets("Options").Range("A1:N1").Find(Range("C1"), lookat:=xlPart)
If Not rngX Is Nothing Then
'MsgBox Chr(34) & Range("C1").Value & Chr(34) & " found at " & rngX.Address
End If
'Check
' Dim groupcounter As Long
' For groupcounter = 1 To 80
' If Worksheets("Options").Range(rngX.Column, groupcounter + 1) = "Y" Then
' getNthRegion(ActiveSheet, groupcounter).Hidden = True
' ElseIf Worksheets("Options").Range(rng.Column, groupcounter + 1) = "N" Then
' getNthRegion(ActiveSheet, groupcounter).Hidden = False
' End If
' Next groupcounter
End If
End Sub
Sub customiseVisibility(ByVal query As String)
Dim cell As Range
Set cell = OptionsSheet.Range("1:1").Find(query)
Dim offset As Long
offset = 1
While Not IsEmpty(cell.offset(offset))
getNthRegion(MySheet, offset).Hidden = cell.offset(offset).Value = "N"
offset = offset + 1
Wend
End Sub
Private Function getRegion(cell As Range) As Range
Dim formatted As Boolean
Dim cell_start, cell_end As Range
'If cell row is 1 then exit function
If cell.Row <= 1 Then Exit Function
'If cell row count > 1 then use first cell selected
If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)
'If selection is outside of used range, do nothing
If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function
'Special condition
If cell.Interior.Color = Me.HeaderColor Then
'Select row below
Set cell = cell.offset(1)
End If
'Get start cell
Set cell_start = cell
While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_start = cell_start.offset(-1)
Wend
'Get end cell
Set cell_end = cell
While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_end = cell_end.offset(1)
Wend
'Get region
Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function
Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
Dim i, counter As Long
For i = 1 To sheet.UsedRange.Rows.Count
If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
counter = counter + 1
End If
If counter = n Then
Set getNthRegion = getRegion(sheet.Cells(i, 1))
Exit Function
End If
Next
End Function
Could you abuse your formatting?
Here is tested code:
Public HeaderColor as Long
Private OptionsSheet as Worksheet
Private DataSheet as Worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
Me.HeaderColor = RGB(217, 217, 217)
set OptionsSheet = sheets("Options")
set DataSheet = ActiveWorksheet
if target.address = "$B$1" then
customiseVisibility target.value
end if
End Sub
Sub customiseVisibility(ByVal query As String)
Dim cell As Range
Set cell = OptionsSheet.Range("1:1").Find(query)
Dim offset As Long
offset = 1
While Not IsEmpty(cell.offset(offset))
getNthRegion(DataSheet, offset).Hidden = cell.offset(offset).Value = "N"
offset = offset + 1
Wend
End Sub
Private Function getRegion(cell As Range) As Range
Dim formatted As Boolean
Dim cell_start, cell_end As Range
'If cell row is 1 then exit function
If cell.Row <= 1 Then Exit Function
'If cell row count > 1 then use first cell selected
If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)
'If selection is outside of used range, do nothing
If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function
'Special condition
If cell.Interior.Color = Me.HeaderColor Then
'Select row below
Set cell = cell.offset(1)
End If
'Get start cell
Set cell_start = cell
While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_start = cell_start.offset(-1)
Wend
'Get end cell
Set cell_end = cell
While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
Set cell_end = cell_end.offset(1)
Wend
'Get region
Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function
Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
Dim i, counter As Long
For i = 1 To sheet.UsedRange.Rows.Count
If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
counter = counter + 1
End If
If counter = n Then
Set getNthRegion = getRegion(sheet.Cells(i, 1))
Exit Function
End If
Next
End Function
Note:
This question is really really specific. Next time try to break your problem down into smaller chunks and take on 1 question at a time (if anything). Also I strongly recommend including example data to work off of. E.G.
| Number | All | PersonA | PersonB | ...
-----------------------------------------
| 1 | N | Y | N | ...
| 2 | N | Y | N | ...
| 3 | N | Y | N | ...
| 4 | N | Y | Y | ...
| 5 | N | N | N | ...
| 6 | N | N | Y | ...
| 7 | N | N | N | ...
| 8 | N | N | Y | ...
As #BigBen suggested - use FIND and then Group between the headers - one row down from Start and one row up from End.
Public Sub CreateOutline()
Dim sFirstAdd As String
Dim rFound As Range
Dim rStart As Range
Dim rEnd As Range
With ThisWorkbook.Worksheets("Sheet1")
.Cells.ClearOutline 'Remove any existing.
With .Cells.EntireColumn
Set rFound = .Find(What:="*", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
Set rStart = rFound
Set rFound = .FindNext(rFound)
Set rEnd = rFound
Range(rStart.Offset(1), rEnd.Offset(-1)).Rows.Group
'Include a marker to state where the end of the last section is.
'Otherwise the last section will go from cell A1 to just below last section header.
If rEnd = "End" Then sFirstAdd = rFound.Address
Loop While rFound.Address <> sFirstAdd
End If
End With
End With
End Sub
Instead of hiding and unhiding rows, you can use the Outline.ShowLevels method to collapse the grouping.
So something like this to:
Test if B1 changed.
Find the corresponding header in the first column.
If there's a match, test if the next row has a grouping (OutlineLevel > 1).
If so, ShowDetail = False for that row.
Note that the use of On Error Resume Next is discouraged. However .ShowDetail = False threw an error when the specified group was already collapsed. As I investigate further, this is the quick fix.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.Range("B1"), Target) Is Nothing Then
With Me
Dim rng As Range
Set rng = .Columns(1).Find(.Range("B1").Value)
If Not rng Is Nothing Then
With rng.Offset(1).EntireRow
On Error Resume Next
If .OutlineLevel > 1 Then .ShowDetail = False
End With
End If
End With
End If
End Sub
I would appreciate your help with the following:
I would like to compare two columns, let us say Column A and Column B, **looking for duplicates**.
If a value in Column A has a match value in Column B, I would like to format the cells of the same duplicate value with the color (the colors are random and different for each match).
This is if `A12 = B30`, the color will be red. And if `A20 = B1`, the color is green and so on.
If there is no match just leave it as it.
That was only an example for red and green. let say you have two columns (A and B).
A1 = 1000
A2 = 2000
A3 = 3000
A4 = 4000
A5 = 5000
A6 = 6000
A7 = 7000
A8 = 8000
A9 = 9000
B1 = 1500
B2 = 9000
B3 = 5000
B4 = 3500
B5 = 7500
B6 = 1000
B7 = 4000
So you have several matches and I need each match to be in random different colors. For example:
A1 = B6 –> They will be colored/highlighted in green
A4 = B7 –> They will be colored/highlighted in red
A5 = B3 –> They will be colored/highlighted in yellow
A9 = B2 –> They will be colored/highlighted in pink
The colors will be different for any match and the non-match will be color less or no change.
I wish this will explain the question and this has to be using excel.
{
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant for at
Dim LstRw As Long
Dim c As Range, clr As Long, x
Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:B" & LstRw)
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For Each c In Rng.Cells
If c = vNum Then
x = Application.WorksheetFunction.CountIf(Rng, vNum)
If x > 1 Then c.Interior.ColorIndex = clr "error here: the code runs fine for around 50 lines then it is stoppedand gives error and pointing to this line"
//Error shows in pop window: Run-time error 'g': Subscript out of range
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
}
This is an adjusted code from my answer here.
https://stackoverflow.com/a/33798531/1392235
Loop through the cells to find the unique values, then loop through the unique values to color the duplicates.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Range, clr As Long, x
Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:B" & LstRw)
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For Each c In Rng.Cells
If c = vNum Then
x = Application.WorksheetFunction.CountIf(Rng, vNum)
If x > 1 Then c.Interior.ColorIndex = clr
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Results
Sample Workbook
EDIT:
Using colorindex limits us to 56 colors, if we use RGB we can increase that. Edit this part of the code, you will have to play with the values get the color variances you like.
If x > 1 Then c.Interior.Color = 1000000 + clr * 100
End If
Next c
clr = clr + 255
I am trying to create some automatism on my excel database.
In this case increment a value if another cell is populated.
Example:
Start a count starting at A21 if B21 contains a number or text.
The count will stop if there is no value on the B adjacent cell.
A B
21 1 Text 1
22 2 Text 2
23 3 Text 3
24
25
So far I got this:
Sub Macro1()
Dim r1 As Range, r2 As Range, cell As Range, mynumber As Long
Set r1 = Range("B21:B2642")
Set r2 = Range("A21:A2642")
mynumber = 1
For Each cell In r1
If cell.Value <> "" Then
cell.Value("A21:A2642") = mynumber
mynumber = mynumber + 1
End If
Next
End Sub
Bests
Work with this,
Sub Button1_Click()
Dim rw As Long, rng As Range, c As Range
rw = 2642
Set rng = Range("B21:B" & rw)
For Each c In rng.Cells
If c <> "" Then
If c.Row = 21 Then
c.Offset(, -1) = 1
Else
c.Offset(, -1) = c.Offset(-1, -1) + 1
End If
End If
Next c
End Sub