MS Excel

Ahoj.

Mám list "Urgence" zde potřebuji podbarvit buňky ve sloupci "A", které mají stejnou hodnotu jako buňka "D3" na listu "Strategické díly.

K tomu se snažím použít
For Each cell In Range("A2:A8000")
If cell(s).Value = Sheets("Strategické díly").Range("D3:D3").Value Then
cell(s).Interior.Color = RGB(0, 204, 255)

Else
s = s + 1
End If
Next

Někde je ale chyba.
Poradíte prosím?

Zaslat odpověď >

elninoslov(8.6.2018 17:53)#040634

Sub Makro1000b()
Dim Cell As Range, D(), Radku As Long, HDN As String, RNG As Range
With wsUrgence
Radku = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If Radku < 2 Then MsgBox "Chybějí data.", vbExclamation, "Oznam": Exit Sub
HDN = wsStrategickeDily.Cells(3, 4).Value2
ReDim D(1 To Radku, 1 To 1)
D = .Cells(2, 1).Resize(Radku).Value2
For Radku = 1 To Radku
If D(Radku, 1) = HDN Then
If RNG Is Nothing Then Set RNG = .Cells(Radku + 1, 1) Else Set RNG = Union(RNG, .Cells(Radku + 1, 1))
End If
Next Radku
End With
If Not RNG Is Nothing Then RNG.Interior.Color = RGB(0, 204, 255)
End Sub
Nechcete Vy náhodou testovať výskyt všetkých zo Strategické díly!D3:D13 ? Inak to môžete kľudne aj Podmieneným formátom.

PS: wsUrgence a wsStrategickeDily som si pomenoval CodeName listov.citovat

Hav-Ran(8.6.2018 17:54)#040635

Asi takto, úprava tučne:

For Each cell In Range("A2:A8000")

If cell.Value = Sheets("Strategické díly").Range("D3:D3").Value Then

cell.Interior.Color = RGB(0, 204, 255)

End If

Next cellcitovat

Raders486(8.6.2018 19:04)#040637

elninoslov - pochopil jste přesně co jsem potřeboval, ale nechtěl jsem moc otravovat.

Tak jsem na každou vyhledávanou položku ze sloupce "D" napsal zvlášť proceduru.

Vím, že mým způsobem to není optimální, ale v celku to funguje.

Moc díky určitě využiji.
Radekcitovat

marjankaj(8.6.2018 19:23)#040639

Radek-Klepacek napsal/a:

Tak jsem na každou vyhledávanou položku ze sloupce "D" napsal zvlášť proceduru.
Radek

Tak toto by zdravého človeka nenapadlo.

citovat

Raders486(8.6.2018 19:36)#040640

Nevím proč, ale vždy to havaruje na
Radku = .Cells(Rows.Count, 1).End(xlUp).Row - 1

Příloha: zip

40640_test.zip (376kB, staženo 22x)

citovat

Stalker(8.6.2018 20:46)#040642

Radek-Klepacek napsal/a:

Nevím proč, ale vždy to havaruje na
Radku = .Cells(Rows.Count, 1).End(xlUp).Row - 1Příloha: 40640_test.zip (376kB, staženo 1x)

Problém je v předchozím řádku
With wsUrgence

CodeName tvého listu je List1

Má tedy být
With List1

ale to ti elninoslov psal hned ve svém příspěvku

PS: wsUrgence a wsStrategickeDily som si pomenoval CodeName listov.citovat

Raders486(8.6.2018 21:19)#040644

Už to vidím, děkuji.citovat

elninoslov(8.6.2018 21:47)#040645

Tak potom napr. takto:
Sub Makro1000c()
Dim Radku As Long, Radku2 As Long, RNG As Range, D()
With wsUrgence
Radku = .Cells(Rows.Count, 1).End(xlUp).Row
Radku2 = wsStrategickeDily.Cells(Rows.Count, 4).End(xlUp).Row
If Radku < 2 Or Radku2 < 3 Then MsgBox "Chybějí data.", vbExclamation, "Oznam": Exit Sub
D = Evaluate("=IF(COUNTIF('Strategické díly'!D3:D" & Radku2 & ",Urgence!A2:A" & Radku & ")>0,True)")
For Radku = 1 To UBound(D)
If D(Radku, 1) Then
If RNG Is Nothing Then Set RNG = .Cells(Radku + 1, 1) Else Set RNG = Union(RNG, .Cells(Radku + 1, 1))
End If
Next Radku
End With
If Not RNG Is Nothing Then RNG.Interior.Color = RGB(0, 204, 255)
End Subcitovat

Téma: Podbarvení buňky na základě jiné buňky

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje