In Excel I have
Column A (Address: example POBOX1234ATLANTAGA30374)
Column B (Address: example POBOX2345ATLANTAGA30384)
I need to make a Column C that shows the difference between the two.
For example, highlight 1234 and 7 as a different font color. I'm open for any ideas on how to do it.
This should do the trick:
Sub CompareCells(c1 As Range, c2 As Range)
Dim p As Long
If c1.Cells.Count + c2.Cells.Count <> 2 Then _
MsgBox "Must specify two single cells.": Exit Sub
For p = 1 To IIf(Len(c2) < Len(c1), Len(c2), Len(c1))
If Mid(c1, p, 1) <> Mid(c2, p, 1) Then c2.Characters(p, 1).Font.Color = vbRed
Next p
End Sub
If your values are in cells A1 and A2, you could use it like this:
CompareCells [a1], [a2]
Sub CompareInColor()
ActiveSheet.Range("C1").Value = ActiveSheet.Range("A1").Value
For i = 1 To Len(ActiveSheet.Range("A1").Value)
If (ActiveSheet.Range("A1").Characters(i, 1).Text <> ActiveSheet.Range("B1").Characters(i, 1).Text) Then
ActiveSheet.Range("C1").Characters(i, 1).Font.Color = RGB(255, 0, 0)
End If
Next i
End Sub
Sub CompareInColorFlip()
ActiveSheet.Range("D1").Value = ActiveSheet.Range("B1").Value
For i = 1 To Len(ActiveSheet.Range("B1").Value)
If (ActiveSheet.Range("B1").Characters(i, 1).Text <> ActiveSheet.Range("A1").Characters(i, 1).Text) Then
ActiveSheet.Range("D1").Characters(i, 1).Font.Color = RGB(255, 0, 0)
End If
Next i
End Sub
This compares A1 and B1 only... Loop through your rows if you have many of them. Also, I assumed that the length of A1 and A2 is the same, otherwise an out-of-range index error may evolve.
Related
I am very new to VBA and have been stuck on this for a few days now.
I would like to compare H2 and H3. If equal then turn the cell green , If not equal then turn the cell red.
Once this is complete I would like to do the same for H4 and H5 , then H6 and H7...... all the way down to the last row of data.
Thank you in advance for your help .
How about something like this?
Sub ForLoopTest()
Dim loop_ctr As Integer
Dim Max As Integer
Max = ActiveSheet.UsedRange.Rows.Count
For loop_ctr = 1 To Max
If loop_ctr Mod 2 = 0 Then
row_below = loop_ctr + 1
If Cells(loop_ctr, "H") = Cells(row_below, "H") then
Cells(loop_ctr, "H").Interior.ColorIndex = 4
Cells(row_below, "H").Interior.ColorIndex = 4
Else
Cells(loop_ctr, "H").Interior.ColorIndex = 3
Cells(row_below, "H").Interior.ColorIndex = 3
End If
End If
Next loop_ctr
End Sub
I still feel like conditional formatting is they way to go here so that it's reactive to values changing in the worksheet, but if you are stuck on VBA as a solution here, something like this should do the trick:
Sub greenOrRed()
Dim lngRow As Long
For lngRow = 2 To Sheet1.Range("H2").End(xlDown).Row Step 2
If Sheet1.Range("H" & lngRow).Value = Sheet1.Range("H" & lngRow + 1).Value Then
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 4
Else 'didn't match
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 3
End If
Next lngRow
End Sub
You could also use a For Each loop to walk down the column which makes for some nice to read code. You just have to apply a test for Mod 2 on the row you are analyzing instead of using the very handy STEP 2 like in the For loop above:
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then
If rngCell.Value = rngCell.Offset(1).Value Then
rngCell.Resize(2).Interior.ColorIndex = 4
Else
rngCell.Resize(2).Interior.ColorIndex = 3
End If
End If
Next rngCell
End Sub
And if you really want to condense it you can apply some boolean math to the setting of the interior.ColorIndex, but this only works because red and green are 1 colorindex value away from each other. Also the next person that adopts your code will hate you and won't think your nearly as clever as you think you are.
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then rngCell.Resize(2).Interior.ColorIndex = 3 + Abs(rngCell.Value = rngCell.Offset(1).Value)
Next rngCell
End Sub
some other ways
another loop approach:
Sub CompareCells()
Dim i As Long
With Range("H2", Cells(Rows.Count,"H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
For i = 1 To .Count Step 2 ' loop through referenced range skipping every other row
With .Cells(i, 1) ' reference current cell
.Interior.Color = IIf(.Value2 = .Offset(1).Value2, vbGreen, vbRed) 'set current cell color with respect to below cell content
End With
Next
End With
End Sub
a no-loop approach:
Sub CompareCells()
With Range("H2", Cells(Rows.Count, "H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
With .Offset(, 1) ' reference referenced range 1 column to the right offset range. this is a "helpre" column
.FormulaR1C1 = "=IF(even(row())=row(),1,"""")" ' write 1's every two rows in referenced range
With .SpecialCells(xlCellTypeFormulas, xlNumbers) ' reference referenced range "numbered" rows
.Offset(, -1).Interior.Color = vbRed ' mark referenced range 1 column left offset in red
.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,"""")" ' signal referenced range cells with 1 if corresponding 1 column to the left offset cell content equals its below cell content
.SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1).Interior.Color = vbGreen ' turn reference referenced range "numbered" cells color to green
End With
.ClearContents ' clear referenced "helper" column
End With
End With
End Sub
I have some values on column A such as:
"A" "B"
1 ok
1 ok
1 me
2 next
2 next
2 next
My code goes and and color the row on "A" if it is all the same, what i want is if column "A" have all one's to check column "B" for the last value which is "me" if it's there, leave those rows with "1" in column A alone, if it's not, delete all the rows that have "1". Not sure how to accomplish that. any help is appreciated.
Dim i As Long
Dim initialPlaceHolderValue As String
Set UsedRng = ActiveSheet.UsedRange
FirstRow = UsedRng(1).Row
LastRow = UsedRng(UsedRng.Cells.Count).Row
r = WorksheetFunction.RandBetween(180, 255)
g = WorksheetFunction.RandBetween(180, 255)
b = WorksheetFunction.RandBetween(180, 255)
initialPlaceHolderValue = Cells(FirstRow + 1, 1).Value
For i = FirstRow + 1 To LastRow
myColor = RGB(r, g, b)
If Cells(i, 1).Value = initialPlaceHolderValue Then
Debug.Print Cells(i, 19).Value
Cells(i, 1).EntireRow.Interior.Color = myColor
Else
Dim myRange As Range
initialPlaceHolderValue = Cells(i, 1).Value
r = WorksheetFunction.RandBetween(180, 255)
g = WorksheetFunction.RandBetween(180, 255)
b = WorksheetFunction.RandBetween(180, 255)
Cells(i, 1).EntireRow.Interior.Color = RGB(r, g, b)
End If
Next i
The following code should achieve what you want (at least what I think you want, your question is not very easily understandable).
Sub RemoveIfNot1AndMe()
For Each cell In Range("Your Range In Column A")
If (cell.Value = "1") Then
If (Range(cell.Address).Offset(0, 1).Value <> "me") Then
Rows(cell.Row).EntireRow.Delete
End If
End If
Next cell
End Sub
Explanations
The loop will go through every cell in your row (could be your column) and if the value is 1 it will check if the cell next to it contains me and if it doesn't delete it.
Something like
"A" "B"
1 ok
1 ok
1 me
2 next
2 next
2 next
Will end up looking like this
"A" "B"
1 ok
1 ok
2 next
2 next
2 next
EDIT
Sub RemoveIfNot1AndMe()
Dim deleteRowsWithValue1 As Boolean
deleteRowsWithValue1 = False
For Each cell In Range("Your range")
If (cell.Value = "1") Then
If (Range(cell.Address).Offset(0, 1).Value = "me") Then
deleteRowsWithValue1 = True
End If
End If
Next cell
If (deleteRowsWithValue1) Then
For i = 1 To Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
If (Range("A" & i).Value = "1") Then
Rows(i).EntireRow.Delete
i = i - 1
End If
Next
End If
End Sub
Something like
"A" "B"
1 ok
1 ok
1 me
2 next
2 next
2 next
Will end up looking like this
"A" "B"
2 next
2 next
2 next
Here is a very basic, brute force approach for you:
Find if there is such a pair of cells: "1" in A-col and "m" in B-col
If Such a pair exist then look for any row with "1" in A-col and NOT "m" in B-column; WARNING: start this at the bottom of the range and look up to the top of the worksheet (otherwise deleting rows is likely to mess up your logic). Delete any such rows.
Redo the LastRow = ... bit since it will become smaller if you deleted any lines.
Do this between the LastRow = ... line and `r = ..." line.
Good luck and share with us your success.
And, btw, it's a good practice to declare ALL the variables if you do declare them at all (as you certainly should). Also, there is no need to declare any WITHIN a loop, over and over again, as you have done there with myRange; just move it to the top of the sub.
I have non-microsoft files that have look along the lines of:
>gibberish that changes
AAARRGGGHHHH
Now, I have a code to make a new .xlsx file out of this to split using Trying to convert files while keeping the old name.
However, I would like the "A2" cell contents to split with each indivual letter being assigned a cell and then have the former contents deleted. I don't mind if this ends up in A3 till AZ.
Thus, the above example I would like to transform to make it look like:
>gibberish that changes
A A A R R G G G H H H H
To clarify "Gibberish that changes" is not a constant it changes per file I have what is denoted here. Same holds true for the second line.
Based on Split cell string into individual cells
I tried this code:
Dim sVar1 as string
Dim sVar2 as string
I = InStr(1, strX, "A" & "R" & "G" & "H")
sVar1 = mid(strX, 1, I)
sVar2 = mid(strx,i+1)
However, this yields no results. It does not cause the Macro to fail (as I get no error message and the rest of the macro works (changing a file into another format and altering the name), but it doesn't do anything. I would like to use the string as the files constantly change in contents and order in cell A2.
I also have no true delimiter as things like ARRGHHHH is written as one word, is that causing the issue?
my 0.02 with Character object
Sub main()
With Range("A2")
For i = 1 To Len(.Value)
.Offset(, i) = .Characters(i, 1).Text
Next i
End With
End Sub
This will parse A2 into its characters and place the characters next to A2, each in its own cell:
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 1 To L
.Offset(0, i).Value = Mid(v, i, 1)
Next i
End With
End Sub
EDIT#1:
This will handle both a range of input cells and the clearing of the original input data. Before:
The new macro:
Sub dural2()
Dim rng As Range, r As Range, v As Variant
Dim L As Long, i As Long
Set rng = Range("A2:A40")
For Each r In rng
v = r.Value
L = Len(v)
For i = 1 To L
r.Offset(0, i - 1).Value = Mid(v, i, 1)
Next i
Next r
End Sub
The result:
Would this be helpful at all?
Sub Test()
Dim i As Integer
Dim num As Integer
num = Len(Range("A1"))
For i = 1 To num
Debug.Print Mid(Range("A1"), i, 1)
Next
End Sub
Try this.
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 0 To L - 1
If i = 0 Then
.Offset(0, i).Value = Left(v, 1)
Else
.Offset(0, i).Value = Mid(v, i, 1)
End If
Next i
End With
End Sub
Input
output
What I am trying to achieve:
I want to fully automate the process of cleaning up exported data.
I want to move the data in the overflow rows into their prospective column. I have tried the following code in VBA. (This is trying to identify the # symbol in the emails and respectively move all email address two places to the right).
Sub qwerty()
Dim D As Range, r As Range
Set D = Intersect(ActiveSheet.UsedRange, Range("D:D"))
For Each r In D
If Left(r.Text, 2) = "#" Then
r.Copy r.Offset(0, 1)
r.Clear
End If
Next r
End Sub
Once the data is in the correct column I need to automate the movement into the correct row. I can easily have them shift up but if one contact doesn't have an email address (as an example) then the emails will be in the wrong rows when they shift up.
Something like this should work:
Sub Tester()
Dim rw As Range, currRow As Long
Dim v, col As Long
Set rw = ActiveSheet.Rows(2)
currRow = 0
Do While rw.Row <= ActiveSheet.UsedRange.Rows.Count
If rw.Cells(2).Value <> "" Then
currRow = rw.Row 'moving "overflow" items to this row...
Else
If currRow > 0 Then
v = rw.Cells(4).Value
col = 0
'Figure out which column item should be moved to...
' "[" is a special character to "Like", so needs to be
' enclosed in "[]"
If v Like "[[]M]:*" Then
col = 8
ElseIf v Like "[[]E]:*" Then
col = 6
ElseIf v Like "[[]H]:*" Then
col = 7
ElseIf v Like "[[]Address]:*" Then
col = 9
End If
'Got a pattern match, so move this item...
'Change ".Copy" to ".Cut" when you're done testing...
If col > 0 Then rw.Cells(4).Copy ActiveSheet.Cells(currRow, col)
End If
End If
Set rw = rw.Offset(1, 0) 'next row....
Loop
End Sub
Is there any efficient way or a correct way to copy and paste within the same worksheet? My code:
With ActiveWorkbook.Sheets("Sheet1")
For Each row In .Rows
If Not row.Columns("A:A") Is Empty Then 'error here
.Columns("A:A").Copy .Range("B1")
End If
Next rw
.Columns("A:A").Delete
End With
So in the code above, I would like to replace the column B with Column A only when the Column A of the cell is NOT empty.
For example:
1 Nil
Nil
24
4 Nil
4 Nil
12
3
7 Nil
2
Nil
8 Nil
Final result will be like this in Column B:
1
Nil
24
4
4
12
3
7
2
Nil
8
EDIT: Never mind, Solved.
With ActiveWorkbook.Sheets("Sheet1")
For rw = 1 To .Rows.Count
If (.Rows(rw).Columns("A:A").Value <> "") Then
.Rows(rw).Columns("A:A").Copy .Range("B" & rw)
End If
Next rw
.Columns("A:A").Delete
End With
With ActiveWorkbook.Sheets("Sheet1").UsedRange
For Each Row In .Rows
If Row.Cells(1, 1) <> "" Then
Row.Cells(1, 2) = Row.Cells(1, 1)
End If
Next
.Columns("A:A").Delete
End With
If you want to fire the the method when any cell from column changes use the method
Worksheet_Change, Here we are catching any change over the cell in the column J only
In this example we copy the values from the column E to G, without including the empty cells. We clear first the column G if this has any old value using this command Worksheets("Sheet1").Range("G:G").ClearContents
Private Sub Worksheet_Change(ByVal Target As Range)
idx = ActiveCell.Row
idxStr = CStr(idx)
labelIdx = "J" + idxStr
Dim ii As Long
Dim columnNumber As Long
ii = 1
columnNumber = 10
If ActiveCell.Column = columnNumber And ActiveCell.Value <> "" Then
Worksheets("Sheet1").Range("F1") = Range(labelIdx).Value
Worksheets("Sheet1").Range("G:G").ClearContents
For Each cell In Worksheets("Sheet1").Range("E:E")
If cell.Value <> "" And cell.Value <> "COLUMN LABEL" Then
Worksheets("Sheet1").Range("G" + CStr(ii)).Value = cell.Value
ii = ii + 1
End If
Next cell
End If
End Sub