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
Related
I have a list of data like this:
I want to add tests from Column N to X bu using a userform.
in the userform i have a combobox populated like this:
For example if add test D for the 1st time it should be Added on column 3, if I add a 2nd test D it should be Added on column 4... If I add test A for the 1time it should be Added on column 1, the seconde test A should be Added on column 2.... (like in the 1st pic)
Each time the name of persons and service is added automatically.
I am trying to set a condition to be able to get what I want I've writen this code:
' code for the button on my worksheet
Private Sub CommandButton1_Click()
'-------------Populate the comobox of persons and tests
Dim ws_Liste_Pers As Worksheet
Set ws_Liste_Pers = ActiveWorkbook.Worksheets("service ")
Fin_Liste_Pers = ws_Liste_Pers.Range("A65530").End(xlUp).Row
For i = 2 To Fin_Liste_Pers
UserForm_SDE.ComboBox_Demandeur.AddItem ws_Liste_Pers.Range("A" & i)
Next i
Dim ws_tech_essais As Worksheet
Set ws_tech_essais = ActiveWorkbook.Worksheets(" tech essais")
Fin_Liste_tech_essais = ws_tech_essais.Range("A65530").End(xlUp).Row
For i = 2 To Fin_Liste_tech_essais
UserForm_SDE.ComboBox_Tech_Essai.AddItem ws_tech_essais.Range("A" & i)
Next
UserForm_SDE.Show
End Sub
'Code for the userfom to add the data
Private Sub CommandButton1_Click()
TPers = Feuil2.[A2].Resize(Feuil2.[A1000000].End(xlUp).Row - 1, 2).Value
ReDim TPlaces(0 To ComboBox_Tech_Essai.ListCount - 1)
Dim LP As Long, LS As Long, CS As Long
LP = ComboBox_Demandeur.ListIndex + 1
' If LP = 0 Then Exit Sub
' If Not ComboBox_Tech_Essai.MatchFound Then Exit Sub
CS = TPlaces(ComboBox_Tech_Essai.ListIndex) + 1: If CS < 14 Then CS = 14
TPlaces(ComboBox_Tech_Essai.ListIndex) = CS
On Error Resume Next
LS = WorksheetFunction.Match(TPers(LP, 3), Feuil2.[A:A], 0)
If Err Then LS = 0
On Error GoTo 0
If LS > 0 Then If Not IsEmpty(Feuil2.Cells(LS, CS).Value) Then LS = 0
If LS = 0 Then
LS = Feuil1.[A1000000].End(xlUp).Row + 1
Feuil1.Cells(LS, 1) = TPers(LP, 1)
' Feuil1.Cells(LS, 2) = TPers(LP, 2)
End If
Feuil1.Cells(LS, CS) = ComboBox_Tech_Essai.Value
Unload Me
End Sub
The problem is that this code is adding the tests only on column N.
Can anyone help me to find teh pb. Thank you
Use the next code, please. In order to properly work, it needs the strings matching the test numbers (from the sheet) to be exactly formatted like in the combo box I mean, like "001", "002" .... I did not observe how you loaded the combo, but it would be necessary to do the same for the range in H:H column. The best text format is obtained by selecting the column in discussion and then: Data tab -> Text to Columns... -> Next -> Next, then check 'Text' in 'Column data format' and press 'Finish':
Private Sub CommandButton1_Click()
Dim sh As Worksheet, rngTNo As Range, rngCol As Range, iRow As Long, i As Long
Dim ComboBox_No As MSForms.ComboBox, ComboBox_Test As MSForms.ComboBox
'use in the next row your real combo boxes. I named mine ComboBox_No, respectively, ComboBox_Test
'You will use something like: Me.ComboBox_Tech_Essai, Me.ComboBox_Demandeur...
Set ComboBox_No = frmTest.ComboBox_No: Set ComboBox_Test = frmTest.ComboBox_Test
Set sh = ActiveSheet 'Feuil2
Set rngTNo = sh.Range("H7:H" & sh.Range("H" & Rows.count).End(xlUp).Row) 'Test numbers range
If rngTNo.cells.count < 1 Then MsgBox _
"There necessary Test numbers range is missing...": Exit Sub
If rngTNo.NumberFormat <> "#" Then MsgBox _
"The Test numbers range must be formatted as text!": Exit Sub
iRow = rngTNo.Find(ComboBox_No.Value).Row 'row to be used for dropping the test
For i = 14 To 25
Set rngCol = sh.Range(sh.cells(7, i), sh.cells(sh.cells(Rows.count, i).End(xlUp).Row, i))
If rngCol.Find(ComboBox_Test.Value) Is Nothing Then
If sh.cells(iRow, i).Value = "" Then
sh.cells(iRow, i).Value = ComboBox_Test.Value: Exit For
End If
End If
Next
End Sub
You have this line of code:
CS = TPlaces(ComboBox_Tech_Essai.ListIndex) + 1: If CS < 14 Then CS = 14
Which is setting the column index you use near the end of your sub:
Feuil1.Cells(LS, CS) = ComboBox_Tech_Essai.Value
14 = N so with the statement If CS < 14 Then CS = 14 the code will never populate a column before N.
#FaneDuru
To do simple look at this picture:
I want to choose the test number from a combobox, and then add the test by chosing it from a combox like this :
when adding a new test the code should look for the test N° on column H and the the name of the chosen test from the combobox, if the test exsits in column N it should be adde in M, if we select the same test the code must add it on the column O ...
column
in the same column I must not have the same test Name, look at the 1st picture for test A in green. ( I have selcted 001 from the combobox so tets A was Added on column N, a second test A N°001 its Added in column M)
For test B in yellow you see that the first value is in column P, because I have selected tets N° OO1, for the 2nd test B I have choosen test Number 002 from the combobox so it was added on column N
I am trying to create a macro VBA that allow me for example:
Column A: 123456789101112 Column F : 6789101112
Only 10 characters in column F. If we have less than 10 characters in column A to complete with 0 for example:
Column A: 123458 Column F: 0000123458
This is the function that allow me to select the number of characters:
For i = 1 To table1Rows - 1
table1(1 + i, 6) = Right(table1(1 + i, 1), 15)
But I need to complete the 10 characters if I have less than 10 in column A.
This will place the formula in column F based on the amount of data in column A.
The formula uses r1c1 notation - R on its own means this row, C1 means column 1.
It's the same as writing =TEXT(RIGHT(A1,10),REPT(0,10)) and dragging down.
Sub Test()
Dim rLastRow As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rLastRow = .Cells(.Rows.Count, 1).End(xlUp) 'Based on column A (column #1)
'Column A Offset by 5 columns is column F.
.Range(.Cells(1, 6), rLastRow.Offset(, 5)).FormulaR1C1 = _
"=TEXT(RIGHT(RC1,10),REPT(0,10))"
End With
End Sub
I think this is what you're after:
For i = 1 To table1Rows - 1
table1(1 + i, 6) = Format(Right(table1(1 + i, 1), 10), "0000000000")
Next
following code will add the remaing zero's to your string:
Dim strnbr As String
strnbr = 123
While Len(strnbr) < 10
strnbr = "0" + strnbr
Wend
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.
I have an Excel document with some plain text in a row. The cells in the range A1:A5 contain texts, then a hundred of rows down there's another few rows with text. Cells between are empty.
I've set up a Do Until loop which is supposed to copy cells with text, and then stop when an empty cell appears. My loop counts and copies 136 cells including the 5 with text.
So my question is why?
The bottom line: Hello ends up on line 136, and then there's a huge gap of empty cells until next area with text. Do the 131 white cells contain any hidden formatting causing this?
I've tried "Clear Formats" and "Clear All". I've also tried using vbNullString instead of " ".
Code snippet:
Sub CopyTags_Click()
Dim assets As Workbook, test As Workbook
Dim x As Integer, y As Integer
Set assets = Workbooks.Open("file-path.xlsx")
Set test = Workbooks.Open("File-path.xlsx")
x = 1
y = 1
Do Until assets.Worksheets(1).Range("A" & x) = ""
test.Worksheets(1).Range("A" & y) = assets.Worksheets(1).Range("A" & x)
x = x + 1
y = y + 1
Loop
test.Worksheets(1).Range("A" & x).Value = "Hello"
End Sub
Use a For Next Statement terminating in the last used cell in column A. Only increment y if there has been a value found and transferred and let the For ... Next increment x.
Sub CopyTags_Click()
Dim assets As Workbook, test As Workbook
Dim x As Long, y As Long
Set assets = Workbooks.Open("file-path.xlsx")
Set test = Workbooks.Open("File-path.xlsx")
x = 1
y = 1
with assets.Worksheets(1)
for x = 1 to .cells(rows.count, 1).end(xlup).row
if cbool(len(.Range("A" & x).value2)) then
test.Worksheets(1).Range("A" & y) = assets.Worksheets(1).Range("A" & x)
y = y + 1
end if
next x
test.Worksheets(1).Range("A" & y).Value = "Hello"
end with
End Sub
have currently browsed the forums and have came up with a code to compare two columns from two separate excel books and then highlight anything matching with the CompareRange. Here is a few more details about the problem:
I have two excel sheets. And data like this in each sheet:
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•6 .6 8 .45
•5 .5 9 .55
•4 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
As you can see, given this example nothing should be highlighted once the macro is run since nothing from Column A or B from the first sheet matches directly with Column N & O from the second sheet. The problem is that with the macro (module) I have come up with will highlight "3" from Column A and ".2" from Column B, just because they appear in Column N & Column O respectivally.
What I want: I only want a number to be highlighted if both the numbers "7" & ".7" are matched in the same row of Column N & Column O on the other spreadsheet. I have no idea how to do this. To be a little more precise, I'll give an example. Say I edited the data to be like this.
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•8 .45 8 .45
•5 .5 9 .55
•11 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
With this data, I would want the second row of A & B ("8" & ".45") highlighted, while my error "3" of Column A and ".2" of Column B is not highlighted. Also, I would like it if row 4 of Column A & B ("11" & ".4") is not highlighted at all either, just because in O it is .2 and in B it would be .4 even though the 11's match.
Please advise. Thanks in advance.
Attached is the macro/module I have entered in which is working kind of correctly but producing the mistake.
And also, (kind of a lesser problem), both the files with data will have the same header, example would be if Column A & Column N both had "Dogs" as it's title in Row 1 and Column B & O both had "Cats" as it's title in Row 1. Is there anyway the macro can be adjusted so it compares those two columns between the two workbooks without me even having to select or assigning a range? Thank you so much.
Sub Find_Matches()
Dim Column1 As Range
Dim Column2 As Range
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
If Column1.Columns.Count > 1 Then
Do Until Column1.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
Loop
End If
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
If Column2.Columns.Count > 1 Then
Do Until Column2.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column2.Rows.Count <> Column1.Rows.Count Then
Do Until Column2.Rows.Count = Column1.Rows.Count
MsgBox "The second column must be the same size as the first"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column1.Rows.Count = 65536 Then
Set Column1 = Range(Column1.Cells(1), Column1.Cells(ActiveSheet.UsedRange.Rows.Count))
Set Column2 = Range(Column2.Cells(1), Column2.Cells(ActiveSheet.UsedRange.Rows.Count))
End If
Dim CompareRange As Variant, x As Variant, y As Variant
' Set CompareRange equal to the range to which you will
' compare the selection.
Set CompareRange = Workbooks("Book4").Worksheets("Sheet1").Range("N2:N7")
Set CompareRange1 = Workbooks("Book4").Worksheets("Sheet1").Range("O2:O7")
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' each cell in CompareRange.
For Each x In Column1
For Each y In CompareRange
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
For Each x In Column2
For Each y In CompareRange1
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
End Sub
Replace both of your loops with one that compares both pairs of cells at the same time:
For i = 1 To Column1.Rows.Count
For j = 1 To compareRange.Rows.Count
If Column1.Cells(i, 1) = compareRange.Cells(j, 1) Then
If Column2.Cells(i, 1) = compareRange1.Cells(j, 1) Then
Column1.Cells(i, 1).Interior.Color = vbYellow
Column2.Cells(i, 1).Interior.Color = vbYellow
End If
End If
Next j
Next i