I have 2 sets of data in two cells (A1 and B1) without any special character (.,/;:'"-##$%^&*(){}[]) and also no space between words,
The problem is I need to compare both the cells and identify and highlight the difference.
For example :
(A1): howtobuilfmacroincludingthesecrria
(B1): howbuilfmacroincludingthesecriteria
in A1 ite is missing
and B1 to is missing
The macro should highlight ite in B1 and to in A1
Make sure the text strings are in cells A1 and B1.
Place these routines in a standard code module (Alt-F11).
Run the FindDistinctSubstrings routine (Alt-F8 from the worksheet).
Public Sub FindDistinctSubstrings()
Dim a$, b$
a = [a1]
b = [b1]
S1inS2 0, 2, a, b, [a1], vbRed
S1inS2 0, 2, b, a, [b1], vbRed
S1inS2 1, 3, a, b, [a1], vbBlack
S1inS2 1, 3, b, a, [b1], vbBlack
End Sub
Private Sub S1inS2(yes&, k&, s1$, s2$, r As Range, color&)
Dim i&
For i = 1 To Len(s1)
If (yes = 0 And 0 = InStr(s2, Mid$(s1, i, k))) Or (yes = 1 And 0 < InStr(s2, Mid$(s1, i, k))) Then
r.Characters(i, k).Font.color = color
End If
Next
End Sub
it's very difficult to perform mutual checks because excel doesn't know the words. What does it words represent?
You can do check on one column like this:
Sub CompareMacro()
Dim columnA As Integer
Dim columnB As Integer
Dim NumberOfCaracters As Integer
Dim f As Integer
f = 1
For numbuerOfRows = 1 To 5
columnA = Len(Worksheets(1).Cells(numbuerOfRows, 1))
columnB = Len(Worksheets(1).Cells(numbuerOfRows, 2))
If columnA > columnB Then
NumberOfCharacters = columnA
Else
NumberOfCaracters = columnB
End If
Dim columnALetters(3) As Variant
For i = 1 To NumberOfCaracters
If Mid(Worksheets(1).Cells(numbuerOfRows, 1), i, 1) = Mid(Worksheets(1).Cells(numbuerOfRows, 2), f, 1) Then
f = f + 1
Else
Worksheets(1).Cells(numbuerOfRows, 1).Characters(i, 1).Font.Color = vbRed
End If
Next i
Next numbuerOfRows
End Sub
You can use object and then use msword concept first A1 content in one and other in second and compare two of them any n no.of words is there it shows and highlight.
Related
I want to run a macro that changes the line of text in column E to red if the text starts with a date that is in this month. I have put a formula in cell E1 which is month/year e.g. 08/22. I have tried to run this formula and I get no errors but the text is not changing to red.
Sub Text_To_Red()
'
' Text_To_Red Macro
'
Dim D As String
Dim P As Integer
Dim L As Integer
For E = 9 To 5000
D = Range("E1").Value
P = InStr(Cells(E, 11).Value, D)
L = Len(Cells(E, 11).Value)
If InStr(1, Worksheets("Live Project Notes").Cells(E, 11), D) <> 0 Then
Worksheets("Live Project Notes").Cells(E, 11).Characters(Start:=P - 2, Length:=L).Font.ColorIndex = 3
End If
Next
MsgBox ("Font Colour Change Complete")
Cells(1, 1).Select
End Sub
I have a table with several week ending dates at the top of each column. I want to search a row for any column with data in and then return, in a list, all the column titles that had data in.
I have attached a picture to better show what I mean, in the picture I have simply typed the dates in. I would like a formula, maybe VBA? that can do this for me but its proving more difficult than I thought.
What final result should look like
Really appreciate any help!
Thanks
** edit: I have found a formula which works but will be incredibly long. Surely there is a way to combine and shorten?
=IF(C5<>0,TEXT(C1,"dd/mm")&" | ","")&IF(D5<>0,TEXT(D1,"dd/mm")&" | ","")&IF(E5<>0,TEXT(E1,"dd/mm"),"")
The above code only works in 3 columns too... Not the required 60 plus!
Paste this code into a module, and in cell B2 type =IFERROR(getNonBlankCells($C$1:$K$1,C2:K2),"") and drag it down to B5.
Function getNonBlankCells(Rng1 As Range, Rng2 As Range) As Variant
Dim i As Integer, j As Integer, n As Integer, test As String
Dim A As Variant, B As Variant, ret(), newret(), t As Integer, p As Integer
n = Rng1.Columns.Count
ReDim ret(1 To n, 0)
A = Rng1.Value2
B = Rng2.Value2
i = 1
For j = 1 To n
If B(1, j) <> "" Then
ret(i, 0) = A(1, j)
i = i + 1
End If
Next j
ReDim newret(LBound(ret) To UBound(ret))
For t = LBound(ret) To UBound(ret)
If ret(t, 0) <> "" Then
p = p + 1
newret(p) = ret(t, 0)
End If
Next t
ReDim Preserve newret(LBound(newret) To p)
getNonBlankCells = Join(newret, ", ")
End Function
I want a formula for column E3 depend on column A3,B3,C3 and D3. If multiple columns show yes or single column show yes I want show as below in pink. Need to combine shctin names which show "yes".Formula required for column E .End result shoul show as pink color.
Check it out
Sub Button1_Click()
Dim x, y, z
For x = 3 To 15
For y = 1 To 4
If UCase(Cells(x, y)) = "YES" Then
z = z & "_" & Cells(2, y)
End If
Next y
Cells(x, 5) = Right(z, Len(z) - 1)
z = ""
Next x
End Sub
User Defined Function,the function code belongs in a regular module.
Place this formula in E3 and drag down,
=Get_It(A3:D3,2)
Function Get_It(a As Range, Return_Row As String)
Dim c As Range
Dim s As String
For Each c In a.Cells
If UCase(c) = "YES" Then
s = s & "_" & Cells(Return_Row, c.Column)
End If
Next c
Get_It = Right(s, Len(s) - 1)
End Function
There's another way using formulas. A little ugly but ok as a non-VBA alternative.
I have an excel set for which I need to count entries based on names. They're all in the same column and there is supposed to be 4 of each entry. I need a formula to count the number of cells with the same entry that do NOT start with either "Retail" or "Commercial" and only return the names in the cells for which there is NOT 4. For example, if my data looks thusly:
NAME
Retail - John
Retail - Sue
Kara
Kara
Joe
Joe
Joe
Joe
Commercial
Sarah
I want a formula that will search this column, and only return "Kara - 2" and "Sarah - 1". The "Retail" and "Commercial" are excluded from the start and since "Joe"=4 I'm not concerned with that. Is there some way I can have this search the column, have it return the first count to meet that criteria to C1, the next one to C2 and so on until I have a column of just the non-compliant entries? I'd love an output like below:
NAME COUNT
Kara 2
Sarah 1
Thanks for looking, I really appreciate any help and advice you can offer!
If your data is in column A the results table will be in columns B & C after running this macro:
Sub MAIN()
Dim A As Range, wf As WorksheetFunction
Dim s1 As String, s2 As String
Dim col As Collection
Set A = Intersect(Range("A:A"), ActiveSheet.UsedRange)
Set wf = Application.WorksheetFunction
Set col = MakeColl(A)
s1 = "Retail"
s2 = "Commercial"
K = 1
For i = 1 To col.Count
v = col.Item(i)
If InStr(v, s1) = 0 And InStr(v, s2) = 0 Then
n = wf.CountIf(A, v)
If n <> 4 Then
Cells(K, "B").Value = v
Cells(K, "C").Value = n
K = K + 1
End If
End If
Next i
End Sub
Public Function MakeColl(rng As Range) As Collection
Set MakeColl = New Collection
Dim r As Range
On Error Resume Next
For Each r In rng
v = r.Value
If v <> "" Then
MakeColl.Add v, CStr(v)
End If
Next r
MsgBox MakeColl.Count
End Function
I'm trying to figure the cleanest way of showing, as an example, an initial value say 300 as x and a critical path say 1.5 as y. Both of these values can change, via input on the sheet.
Together with these values we have a resource of a and b. In this scenario a will fill 200 cells within a row and b will fill 100.
As I alluded to before, x and y can change, say, if y is 2, a fills 150 and b fills 150. And if y is 1 then only a fills 300.
Currently i'm using If statements, but I feel this is messy and could potentially lead to endless code in order to cover every possible outcome and I'm in need of a better solution.
Here is a simplistic example of what I'm currently achieving:
Private Sub Example()
Dim ActiveWB As Worksheet
Set ActiveWB = ActiveWorkbook.Sheets("Sheet1")
Dim cell As Range
Dim a, b, x, y As Double
x = ActiveWB.Range("A1").Value
y = ActiveWB.Range("A2").Value
a = x / y
b = x - a
For Each cell In ActiveWB.Range(Cells(3, 1), Cells(3, a))
If (cell.Column >= 0) And (cell.Column <> x) Then
If (y = 1) And (a > 0) Then
cell.Value = "a"
a = a - 1
ElseIf (y > 1) And (y < 2) And (a > 0) Then
cell.Value = "a"
a = a - 1
If (b > 0) Then
cell.Offset(1, 0).Value = "b"
b = b - 1
End If
ElseIf (y >= 2) And (y < 2.5) And (a > 0) Then
cell.Value = "a"
a = a - 1
If (b > 0) Then
cell.Offset(1, 0).Value = "b"
b = b - 1
End If
'..... and so on......
End If
End If
Next cell
End Sub
Any suggestions would be much appreciated. Thank you for your time. Y.
First of all declaring types should be done for each variable separately:
Dim a, b, x, y As Double
Becomes:
Dim a As Double, b As Double, x As Double, y As Double
Or (this is what I prefer):
Dim a As Double
Dim b As Double
Dim x As Double
Dim y As Double
Second, if your a and b are only used for determining the range width, then they are preferably not of a floating point type. In stead use Integer (under 2^15) or Long:
Dim a As Integer
Dim b As Integer
Dim x As Double
Dim y As Double
Then your value assignment to a and b cannot stay the way they are now, but should read something like:
a = Int(x / y)
b = Int(x - a)
Then I hope your x and y values are restricted to values > 0 and x > y in your sheet. If not then first test for that in your script...
Now last (and your original question), you can assign a value to a complete range of cells if you like:
If a > 0 Then Range(Cells(3, 1), Cells(3, a)).Value = "a"
If b > 0 Then Range(Cells(4, 1), Cells(4, b)).Value = "b"
I dont understand why you take of 1 from a and b, so if that really add something, please elaborate a bit more on the general logic...
I probably don't completely understand the complexity, but based upon what you shared you can replace your for loop with the following to achieve the same result:
ActiveWB.Range(Cells(3, 1), Cells(3, a)).Value = "a"
If b > 0 then
ActiveWB.Range(Cells(4, 1), Cells(4, b)).Value = "b"
End If