No teď mě napadlo, že to vždy končí "min" , ale jak to tam implementovatcitovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: VBA změnit barvu textu
MS Excel
Téma: VBA změnit barvu textu 
Zaslal/a Fantasyk 3.4.2021 16:57
Zdravím,
chtěl bych se zeptat, jestli lze makrem vyhledat určený text a přebarvit ho ?
Např.:
Nezapsané prostoje- 1h47min, NOK stanice - 1h4min,
Přechod - změna MIX/UL- 11min, MIX Váha - šnek / Vibrátor- 32min, Start-up / Čekání na Start-up - měření teplot- 11min,
a přebarvit část textu např. Nezapsané prostoje- 1h47min
, ale ten čas je pokaždé jiný..
tzv. kliknu na tlačítko a pokud najde Nezapsané prostoje + časy v některých buňkách tak je přebarví na červenou
Mám udělané zatím tohle:
Set myRange = Range("A1:A100")
substr = "Nezapsané prostoje-"
txtColor = 3
For Each myString In myRange
lenstr = Len(myString)
lensubstr = Len(substr)
For i = 1 To lenstr
tempString = Mid(myString, i, lensubstr)
If tempString = substr Then
myString.Characters(Start:=i, Length:=lensubstr).Font.ColorIndex = txtColor
End If
Next i
Next myString
, ale nevím jak přidat ten čas který se mění 
Díky za radu
pr.:
Sub ColoringText()
Dim myRange As Range, D()
Dim substr As String, endstr As String
Dim txtColor As Long, x As Long, y As Long, Pos As Long, endPos As Long, startPos As Long, LenEndStr As Long
Set myRange = Worksheets("Hárok1").Range("A1:A100")
If myRange.Cells.Count > 1 Then D = myRange.Value Else ReDim D(1, 1): D(1, 1) = myRange.Value
substr = "Nezapsané prostoje-"
endstr = "min"
txtColor = 3
LenEndStr = Len(endstr)
For y = 1 To UBound(D, 1)
For x = 1 To UBound(D, 2)
Pos = 1
Do
startPos = InStr(Pos, D(y, x), substr, vbTextCompare)
If startPos <> 0 Then
endPos = InStr(startPos, D(y, x), endstr, vbTextCompare)
If endPos <> 0 Then
myRange.Cells(y, x).Characters(Start:=startPos, Length:=endPos - startPos + LenEndStr).Font.ColorIndex = txtColor
Pos = endPos + LenEndStr
End If
End If
Loop Until startPos = 0 Or endPos = 0
Next x
Next y
End Subcitovat
Sub ColoringText()
Dim myRange As Range, D()
Dim substr As String, endstr As String
Dim txtColor As Long, x As Long, y As Long, Pos As Long, endPos As Long, startPos As Long, LenEndStr As Long
Set myRange = Worksheets("Hárok1").Range("A1:A100")
If myRange.Cells.Count > 1 Then D = myRange.Value Else ReDim D(1, 1): D(1, 1) = myRange.Value
substr = "Nezapsané prostoje-"
endstr = "min"
txtColor = 3
LenEndStr = Len(endstr)
For y = 1 To UBound(D, 1)
For x = 1 To UBound(D, 2)
Pos = 1
Do
startPos = InStr(Pos, D(y, x), substr, vbTextCompare)
If startPos <> 0 Then
endPos = InStr(startPos, D(y, x), endstr, vbTextCompare)
If endPos <> 0 Then
myRange.Cells(y, x).Characters(Start:=startPos, Length:=endPos - startPos + LenEndStr).Font.ColorIndex = txtColor
Pos = endPos + LenEndStr
End If
End If
Loop Until startPos = 0 Or endPos = 0
Next x
Next y
End Subcitovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články