PDA

View Full Version : VBA Code to go through one column cells, I don't have range, I have only one column?



hjameelq
08-15-2016, 03:25 AM
I need to make a loop and go through column cells, I want to check if the value of cell is greater than 18.

Also, there is another issue is how can i detect the cells with arabic text, I need to highlight these cells in whole sheet not only in specific range!

gmaxey
08-15-2016, 06:18 AM
I am just a dabbler so something far better may come along. For the first part:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim lngCount As Long, lngIndex As Long
lngCount = Cells(Rows.Count, "A").End(xlUp).Row
For lngIndex = 1 To lngCount
If IsNumeric(Cells(lngIndex, "A").Value) And Cells(lngIndex, "A").Value > 18 Then
Cells(lngIndex, "B").Value = "Flagged"
End If
Next lngIndex
lbl_Exit:
Exit Sub
End Sub

Paul_Hossler
08-15-2016, 06:33 AM
Hmmm - double posted ??

Paul_Hossler
08-15-2016, 06:44 AM
Uses intrinsic Excel capability (Filter) to avoid looping




Option Explicit
Const iLimit As Long = 18

Sub HighlightCells()

ActiveSheet.Range("$A$1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & iLimit, Operator:=xlAnd

On Error Resume Next
Intersect(ActiveSheet.Columns(1).SpecialCells(xlCellTypeVisible), ActiveSheet.AutoFilter.Range).Interior.Color = vbRed
On Error GoTo 0

ActiveSheet.AutoFilterMode = False

End Sub





You might have to tweak it if there's column headers



Option Explicit
Const iLimit As Long = 18
Sub HighlightCells()
Dim r As Range

With ActiveSheet
.Range("$A$1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & iLimit, Operator:=xlAnd

On Error Resume Next
Set r = Intersect(.Columns(1).SpecialCells(xlCellTypeVisible), .AutoFilter.Range)
Set r = Intersect(r, Range(.Rows(2), .Rows(.Rows.Count)))
r.Interior.Color = vbGreen
On Error GoTo 0

.AutoFilterMode = False
End With
End Sub

gmaxey
08-15-2016, 06:56 AM
Paul,

The dabbler (me) is trying to learn a little about Excel. Can you offer a little explanation on "Intersect" (how it works in this case) and while probably unlikely, if the column of interest has both numbers and text the filter considers text as > 18. How would you modify the filter so that it only returns numeric values >18? Thanks.

Paul_Hossler
08-15-2016, 06:57 AM
If the text is in a different font, you could look for that --- cell by cell

gmaxey
08-15-2016, 07:11 AM
Paul,

Never mind the part about text returning > 18. That doesn't seem to be the case now :-)

Paul_Hossler
08-15-2016, 08:38 AM
Paul,

The dabbler (me) is trying to learn a little about Excel. Can you offer a little explanation on "Intersect" (how it works in this case) and while probably unlikely, if the column of interest has both numbers and text the filter considers text as > 18. How would you modify the filter so that it only returns numeric values >18? Thanks.

Actually, looking (and thinking) a little more, the original was unnecessarily complex with an unneeded Intersect



Sub HighlightCellsBetter()
Dim r As Range

With ActiveSheet
.Range("$A$1").CurrentRegion.AutoFilter Field:=1, Criteria1:=">" & iLimit, Operator:=xlAnd

On Error Resume Next
Set r = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
Set r = Intersect(r, Range(.Rows(2), .Rows(.Rows.Count)))
r.Interior.Color = vbRed
On Error GoTo 0

.AutoFilterMode = False
End With
End Sub



First Set r = the worksheet's (Activesheet) data block that is filtered ( .AutoFilter.Range) only the first column and only the cells that are visible (i.e. not filtered out)

This includes (probably) the column header in typically A1

Range(.Rows(2), .Rows(.Rows.Count)) is the range for the WS rows2 - the last row (.Rows.Count) -- used to be 65K rows max, now 1M+, so I don't like to hard code assumptions

So the second Set r = is the cells in rows 2 - end that are also visible in the original block of filtered data

I'm reusing the variable r, but it could be Set r2 = Intersect(r, Range(.Rows(2), .Rows(.Rows.Count)))

Single step through the attachment and you'll get it

hjameelq
08-15-2016, 08:41 AM
Thanks it worked :)
Can I ask another question:

Is there way to convert Arabic numbers to English numbers.

Thanks,

gmaxey
08-15-2016, 09:43 AM
Paul, thanks for the explanation and examples.

Paul_Hossler
08-15-2016, 10:02 AM
Thanks it worked :)
Can I ask another question:

Is there way to convert Arabic numbers to English numbers.

Thanks,


1. You're welcome

2. Sure

3. Strictly speaking, '0', '1', ... '9' are Arabic numbers, as opposed to 'I', 'V', ..., '"M' which are Roman numerals

Can you post an example since I don't think that's what you meant.

It 'might' be possible to replace 'Arabic 1' with '1', 'Arabic 2' with '2','Arabic 3' with '3', etc. on a character by character basis

hjameelq
08-15-2016, 11:50 AM
Ya look at that:


١


٣


٤


٤


٥


١


٢

١


٣


٤










These numbers are written in Arabic, can we convert them to English like 1, 2, 3, 4, 5,

Paul_Hossler
08-15-2016, 01:17 PM
This is the best I could come up with





Option Explicit
Function Arabic2English(s As String) As String
Dim s1 As String, s2 As String
Dim i As Long

For i = 1 To Len(s)
Select Case Mid(s, i, 1)
Case ChrW(1632): s1 = s1 & ChrW(48)
Case ChrW(1633): s1 = s1 & ChrW(49)
Case ChrW(1634): s1 = s1 & ChrW(50)
Case ChrW(1635): s1 = s1 & ChrW(51)
Case ChrW(1636): s1 = s1 & ChrW(52)
Case ChrW(1637): s1 = s1 & ChrW(53)
Case ChrW(1638): s1 = s1 & ChrW(54)
Case ChrW(1639): s1 = s1 & ChrW(55)
Case ChrW(1640): s1 = s1 & ChrW(56)
Case ChrW(1641): s1 = s1 & ChrW(57)
Case Else
s1 = s1 & Mid(s, i, 1)
End Select
Next i

Arabic2English = s1
End Function


Function English2Arabic(s As String) As String

Dim s1 As String, s2 As String
Dim i As Long

s1 = StrConv(s, vbUnicode)

For i = 1 To Len(s1)
Select Case Mid(s1, i, 1)
Case ChrW(48): s2 = s2 & ChrW(1632)
Case ChrW(49): s2 = s2 & ChrW(1633)
Case ChrW(50): s2 = s2 & ChrW(1634)
Case ChrW(51): s2 = s2 & ChrW(1635)
Case ChrW(52): s2 = s2 & ChrW(1636)
Case ChrW(53): s2 = s2 & ChrW(1637)
Case ChrW(54): s2 = s2 & ChrW(1638)
Case ChrW(55): s2 = s2 & ChrW(1639)
Case ChrW(56): s2 = s2 & ChrW(1640)
Case ChrW(57): s2 = s2 & ChrW(1641)
Case Else
s2 = s2 & Mid(s1, i, 1)
End Select
Next i

English2Arabic = s2
End Function

hjameelq
08-16-2016, 04:06 AM
Thanks Paul, it perfectly worked.

Paul_Hossler
08-16-2016, 08:11 AM
Glad

There's ways to reduce the line count, but I opted for simplicity