I want to get the format properties of each cell in column E. I have no issue to identify the properties if the text that is
in each cell has a unique Font.Name, Font.Size, Font.ColorIndex and Font.FontStyle.
The issue I have is that in some cells there is text with one format and other text with another and in that case my current code it seems that is only printing
the format of the first character.
for example in one cell is abc def., where abc is Arial, 9, black, Regular and def is Calibri, 18, green, Bold:
How to identify all format properties in each cell?
My current code is below:
Sub GetFormat()
For i = 1 To 8
nName = Cells(i, "E").Font.Name
sSize = Cells(i, "E").Font.Size
cColor = Cells(i, "E").Font.ColorIndex
sStyle = Range("E" & i).Font.FontStyle
Cells(i, "A") = nName
Cells(i, "B") = sSize
Cells(i, "C") = cColor
Cells(i, "D") = sStyle
Next
End Sub
You'll need to loop over each cell's Characters collection and check each character in turn.
For example:
Sub Tester()
Dim rng As Range, c, n As Long
Set rng = Range("A1")
For n = 1 To rng.Characters.Count
With rng.Characters(n, 1)
Debug.Print n, "Bold", .Font.Bold
Debug.Print n, "Color", .Font.ColorIndex
End With
Next
End Sub
Related
I am working on my vba exercise and I have two columns L and I. The value in column I depends on column L.
So if column L has value "s" in a row then column I should have value "0" in the same row, otherwise the I, L column should be colored red.
If column L has one of the values in array in a row then column I should have nothing in the same
row, otherwise the I, L column should be colored red.
The problem is I struggle to make it work in VBA
Also, even if there is a way to do it differently then in VBA I have to do this exercise in VBA.
How can I compare values from the same row that are in two different columns that are not next to each other? Can you help?
Sub validate()
Dim i As Long
Set active_sheet = ActiveSheet
LstRow = active_sheet.Range("I" & active_sheet.Rows.Count).End(xlUp).Row
Set RngOrders = active_sheet.Range("L2:L" & last_row)
Set RngPackages = active_sheet.Range("I2:L" & LstRow)
MValues = Array("M", "kg", "j.m.", "g")
For i = 1 To RngPackages
If RngOrders(i) = "s" And RngPackages(i) <> "0" Then
RngPackages(i).Interior.Color = vbRed
ElseIf RngOrders(i) in MValues And RngPackages(i) <> "" Then
RngPackages(i).Interior.Color = vbRed
Next i
End Sub
Sub validate_someones_homework()
' Tools -> References -> Microsoft Scripting Runtime -> check
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim MValues As New Scripting.Dictionary
MValues.Add "M", 0
MValues.Add "kg", 0
MValues.Add "j.m.", 0
MValues.Add "g", 0
Dim r As Long
For r = 1 To lastRow
If ws.Cells(r, 12).Value = "s" And Not ws.Cells(r, 9).Value = 0 Then
ws.Cells(r, 9).Interior.Color = vbRed
ElseIf MValues.Exists(ws.Cells(r, 12).Value) And Not ws.Cells(r, 9).Value = "" Then
ws.Cells(r, 9).Interior.Color = vbRed
End If
Next r
End Sub
I am trying to create a For and Do while loop in VBA. I want that when the value 'X' is entered in column A and if column W is equal to "T", all the rows below (column A) should be checked "X" until the next value "T" in column W.
My script does not work, only the row below is filled with "X" and the file closes (bug!)
Here is the complete code
Sub Chaine()
For Each Cell In Range("A2:A3558")
If UCase(Cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While Cell.Offset(0, 23) <> "T"
Cell.Offset(1, 0).Value = "X"
Loop
End If
Next Cell
End Sub
Try this:
Sub Chaine()
Dim c As Range, vW, flag As Boolean
For Each c In ActiveSheet.Range("A2:A3558").Cells
vW = UCase(c.EntireRow.Columns("W").value)
If UCase(c.value) = "X" And vW = "T" Then
flag = True 'insert "X" beginning on next row...
Else
If vW = "T" Then flag = False 'stop adding "X"
If flag Then c.value = "X"
End If
Next c
End Sub
Your Do While loop has to be problem as it doesn't change and will continue to check the same thing. It's unclear what you want to happen, but consider something like this as it moves to the right until you've exceeded the usedrange.
Sub Chaine()
Dim cell As Range
For Each cell In Range("A2:A3558").Cells
If UCase(cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While cell.Offset(0, 23) <> "T"
Set cell = cell.Offset(0, 1)
'not sure what this is supposed to do...?
'cell.Offset(1, 0).Value = "X"
If cell.Column > cell.Worksheet.UsedRange.Cells(1, cell.Worksheet.UsedRange.Columns.Count).Column Then
MsgBox "This has gone too far left..."
Stop
End If
Loop
End If
Next cell
End Sub
I just went off your description in the question. Your code is not doing what you want and it's not really how you would do this in my opinion. I figured I would put an answer that does what you ask but, keep it simple.
I'm guessing Target in the code refers to an event.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo SomethingBadHappened
'Checks if you are in the A column from the target cell that
'was changed and checks if only X was typed.
If (Target.Column = 1 And UCase(Target) = "X") Then
Dim colToCheck_Index As Integer
colToCheck_Index = 23 'W Column
Dim colToCheck_Value As String
Dim curRow_Index As Integer
curRow_Index = Target.Cells.Row
'Checks if the column we are checking has only a T as the value.
If (UCase(ActiveSheet.Cells(curRow_Index, colToCheck_Index).Value) = "T") Then
Application.EnableEvents = False
Do
'Set the proper cell to X
Range("A" & curRow_Index).Value = "X"
curRow_Index = curRow_Index + 1
'Set the checking value to the next row and check it in the
'while loop if it doesn't equal only T
colToCheck_Value = ActiveSheet.Cells(curRow_Index, colToCheck_Index)
'Set the last row to X on the A column.
Loop While UCase(colToCheck_Value) <> "T"
Range("A" & curRow_Index).Value = "X"
Application.EnableEvents = True
End If
Exit Sub
SomethingBadHappened:
Application.EnableEvents = True
End If
End Sub
I want to detect if anything about the text is different between two cells.
For example, cells A1 and B1 have the same text but different formatting of the text:
Cell A1: This is my cell.
Cell B1: This is my cell.
The following code does not flag a difference:
'if the text in the cells is different in any way, report a difference
If (ActiveSheet.Cells(1, "A") <> ActiveSheet.Cells(1, "B")) Then
ActiveSheet.Cells(1, "C").Value = DIFFERENT
End If
e.g:
Sub Tester()
Debug.Print SameText(Range("B4"), Range("C4"))
End Sub
'call from VBA or as UDF
Function SameText(rng1 As Range, rng2 As Range) As Boolean
Dim rv As Boolean, c1, c2, x As Long, arr, v
If rng1.Value = rng2.Value Then
rv = True
arr = Array("Underline", "Fontstyle", "Color") '<< for example
For x = 1 To Len(rng1.Value)
Set c1 = rng1.Characters(x, 1).Font
Set c2 = rng2.Characters(x, 1).Font
For Each v In arr
If CallByName(c1, v, VbGet) <> CallByName(c2, v, VbGet) Then
Debug.Print "Mismatch on " & v & " at position " & x, _
rng1.Address, rng2.Address
rv = False
Exit Function
End If
Next
Next x
Else
rv = False
End If
SameText = rv
End Function
I'm not sure whether comparing the cells' .Value(11) XML code will catch every discrepancy you are looking for but it does catch the differences in your example strings' formatting.
With ActiveSheet
Debug.Print .Cells(1, "A").Value(11)
Debug.Print .Cells(1, "B").Value(11)
If .Cells(1, "A").Value(11) <> .Cells(1, "B").Value(11) Then
.Cells(1, "C").Value = "DIFFERENT"
End If
End With
For the unformated cell this element is pretty plain.
...
<Cell><Data ss:Type="String">abcdef</Data></Cell>
...
Not so for the one formatted with bold and strike-through characters.
...
<Cell><ss:Data ss:Type="String" xmlns="http://www.w3.org/TR/REC-html40"><Font
html:Color="#000000">ab</Font><B><S><Font html:Size="8.8000000000000007"
html:Color="#000000">cde</Font></S></B><Font html:Color="#000000">f</Font></ss:Data></Cell>
...
To compare only that <Cell> element,
Dim val11A As String, val11B As String
With ActiveSheet
val11A = Split(Split(.Cells(1, "A").Value(11), "<Cell>")(1), "</Cell>")(0)
val11B = Split(Split(.Cells(1, "B").Value(11), "<Cell>")(1), "</Cell>")(0)
If val11A <> val11B Then
.Cells(1, "C").Value = "DIFFERENT"
End If
End With
Disclaimer- my case is specific, and in my case my code works because I know the pattern.
I was looking for an answer everywhere, and the codes I tried were not quite what I was looking for, this is my solution if you are looking for a set of numbers.
In my case, I was looking for 7 digits, starting with digit 1 in a a column with random strings, some string had the number some others didn't.
The number will appear in these three scenarios "1XXXXXX", "PXXXXXXXX", "PXXXXXXXXX"(this has more digits because there is a slash).
Here are the examples of strings:
9797 P/O1743061 465347 Hermann Schatte Earl Lowe
9797 Po 1743071 404440 Claude Gaudette Jose Luis Lopez
9817 1822037 463889 Jean Caron Mickelly Blaise
My Code
Sub getnum()
'i don't use explicit so i didn't declare everything
Dim stlen As String
Dim i As Integer
Dim arra() As String
Dim arran() As String
Orig.AutoFilterMode = False
Call BeginMacro
LastRow = Orig.Cells(Rows.Count, 1).End(xlUp).Row
Orig.Range("J2:J" & LastRow).Clear
'loop though column
For n = 2 To LastRow
celref = Orig.Cells(n, 4).Value
'split string on white spaces
arra() = Split(celref, " ")
'turn string to multiple strings
For counter = LBound(arra) To UBound(arra)
strin = arra(counter)
'remove white spaces from string
storage = Trim(strin)
lenof = Len(storage)
'if string has 9 characthers, check for conditions
If lenof = 9 Then
'position of first and last charachter
somstr = Mid(storage, 1, 1)
somot = Mid(storage, 9, 1)
If somstr = "P" Or somstr = "p" And IsNumeric(somot) = True Then
'removes Po or PO and keeps only 7 digits
storage = Right(storage, 7)
'stores in column J
Orig.Cells(n, 10).Value = storage
End If
ElseIf lenof = 10 Then
somstr = Mid(storage, 1, 1)
somot = Mid(storage, 10, 1)
'other conditions
If somstr = "P" Or somstr = "p" And IsNumeric(somot) = True Then
'removes Po or PO and keeps only 7 digits
storage = Right(storage, 7)
'stores in column J
Orig.Cells(n, 10).Value = storage
End If
End If
'eliminate comma within
arran() = Split(storage, ",")
If Orig.Cells(n, 10).Value <> storage Then
For counter2 = LBound(arran) To UBound(arran)
strin2 = arran(counter2)
storage2 = Trim(strin2)
'final condition if is 7 digits and starts with 1
If IsNumeric(storage2) = True And Len(storage2) = 7 Then
car = Mid(storage2, 1, 1)
If car = 1 Then
'stores in columns J at specific position
Orig.Cells(n, 10).Value = storage2
End If
Else
If isnumeric(orig.cells(n,10).value) =true and _
len(orig.cells(n,10).value = 7 then
orig.cells(n,10).value = orig.cells(n,10).value
else
Orig.Cells(n, 10).Value = "no po# in D"
End If
Next counter2
End If
Next counter
Next n
Call EndMacro
End Sub
you may try this
Option Explicit
Sub getnum()
Dim position As Variant
Dim cell As Range
With Worksheets("Orig") ' change it to your actual sheet name
With Intersect(.UsedRange, Columns("J"))
.Replace what:="P/O", replacement:="P/O ", lookat:=xlPart
For Each cell In .Cells
position = InStr(cell.Text, " 1")
If position > 0 Then cell.Value = Mid(cell.Value, position + 1, 7)
Next
End With
End With
End Sub
This code paste two formulas one in column G and one in column J). The first formula checks for a "P" in the first character of the cell in column 2 and if there is a "P" it extracts the last 7 characters in the string and puts them in column G. The second formula checks if there is not a "P" and if not extracts the last 7 characters in the string and puts them in column J.
Sub Extract()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet3")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("G2:G" & lRow).Formula = "=IF(LEFT(B2)=""P"",(RIGHT(B2,7)),"""")"
ws.Range("J2:J" & lRow).Formula = "=IF(LEFT(B2)<>""P"",(RIGHT(B2, 7)),"""")"
End Sub
You may use the RegEx to extract the number in desired format.
Please give this a try...
Function Get10DigitNumber(ByVal Str As String) As String
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Global = False
.Pattern = "1\d{6}"
End With
If RE.test(Str) Then
Get10DigitNumber = RE.Execute(Str)(0)
End If
End Function
Then if you want to use this function on the worksheet itself, assuming your string is in A2, try this...
=Get10DigitNumber(A2)
OR
You may use this function in another sub routine/macro like this...
Debug.Print Get10DigitNumber(<pass your string variable here>)
Edited Function:
Function Get10DigitNumber(ByVal Str As String) As String
Dim RE As Object, Matches As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Global = False
.Pattern = "[Pp]?\/?[Oo]?(1\d{6})\b"
End With
If RE.test(Str) Then
Set Matches = RE.Execute(Str)
Get10DigitNumber = Matches(0).SubMatches(0)
End If
End Function
And use if as already described above.
After understanding what you were doing, I think this will work. Any feedback would be appreciated.
Dim cell As Range, LRow As Long
LRow = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
For Each cell In Range("D2:D" & LRow)
If cell.Value Like "*Po *" Then
cell.Offset(0, 6).Value = Split(cell.Value, " ")(2)
Else: cell.Offset(0, 6).Value = Split(cell.Value, " ")(1)
End If
Next cell
For Each cell In Range("J2:J" & LRow)
If Len(cell.Value) > 7 Then
cell.Value = Right(cell.Value, 7)
End If
Next
I wanted to color highlight cells that are different from each other; in this case colA and colB. This function works for what I need, but looks repetitive, ugly, and inefficient. I'm not well versed in VBA coding; Is there a more elegant way of writing this function?
EDIT
What I'm trying to get this function to do is:
1. highlight cells in ColA that are different or not in ColB
2. highlight cells in ColB that are different or not in ColA
Sub compare_cols()
Dim myRng As Range
Dim lastCell As Long
'Get the last row
Dim lastRow As Integer
lastRow = ActiveSheet.UsedRange.Rows.Count
'Debug.Print "Last Row is " & lastRow
Dim c As Range
Dim d As Range
Application.ScreenUpdating = False
For Each c In Worksheets("Sheet1").Range("A2:A" & lastRow).Cells
For Each d In Worksheets("Sheet1").Range("B2:B" & lastRow).Cells
c.Interior.Color = vbRed
If (InStr(1, d, c, 1) > 0) Then
c.Interior.Color = vbWhite
Exit For
End If
Next
Next
For Each c In Worksheets("Sheet1").Range("B2:B" & lastRow).Cells
For Each d In Worksheets("Sheet1").Range("A2:A" & lastRow).Cells
c.Interior.Color = vbRed
If (InStr(1, d, c, 1) > 0) Then
c.Interior.Color = vbWhite
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Ah yeah that's cake I do it all day long. Actually your code looks pretty much like the way I'd do it. Although, I opt to use looping through integers as opposed to using the "For Each" method. The only potential problems I can see with your code is that ActiveSheet may not always be "Sheet1", and also InStr has been known to give some issues regarding the vbTextCompare parameter. Using the given code, I would change it to the following:
Sub compare_cols()
'Get the last row
Dim Report As Worksheet
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set Report = Excel.Worksheets("Sheet1") 'You could also use Excel.ActiveSheet _
if you always want this to run on the current sheet.
lastRow = Report.UsedRange.Rows.Count
Application.ScreenUpdating = False
For i = 2 To lastRow
For j = 2 To lastRow
If Report.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, Report.Cells(j, 2).Value, Report.Cells(i, 1).Value, vbTextCompare) > 0 Then
'You may notice in the above instr statement, I have used vbTextCompare instead of its numerical value, _
I find this much more reliable.
Report.Cells(i, 1).Interior.Color = RGB(255, 255, 255) 'White background
Report.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(i, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(i, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
'Now I use the same code for the second column, and just switch the column numbers.
For i = 2 To lastRow
For j = 2 To lastRow
If Report.Cells(i, 2).Value <> "" Then
If InStr(1, Report.Cells(j, 1).Value, Report.Cells(i, 2).Value, vbTextCompare) > 0 Then
Report.Cells(i, 2).Interior.Color = RGB(255, 255, 255) 'White background
Report.Cells(i, 2).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(i, 2).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(i, 2).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Things I did differently:
I used my integer method described above (as opposed to the 'for each' method).
I defined the worksheet as an object variable.
I used vbTextCompare instead of its numerical value in the InStr function.
I added an if statement to omit blank cells. Tip: Even if only one
column in the sheet is extra long (e.g., cell D5000 was accidentally
formatted), then the usedrange for all columns is considered 5000.
I used rgb codes for the colors (it's just easier for me since I
have a cheat sheet pinned to the wall next to me in this cubicle
haha).
Well that about sums it up. Good luck with your project!
'Compare the two columns and highlight the difference
Sub CompareandHighlight()
Dim n As Integer
Dim valE As Double
Dim valI As Double
Dim i As Integer
n = Worksheets("Indices").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
Application.ScreenUpdating = False
For i = 2 To n
valE = Worksheets("Indices").Range("E" & i).Value
valI = Worksheets("Indices").Range("I" & i).Value
If valE = valI Then
Else:
Worksheets("Indices").Range("E" & i).Font.Color = RGB(255, 0, 0)
End If
Next i
End Sub
' I hope this helps you