Ha kevés az időd és csak a videó érdekel, itt megtalálod.
Előfordult már, hogy az adott munkalapon az összes cellát ki kellett jelölnöd egy vagy több szín alapján? Ha a kijelölendő cellák egy oszlopban vannak, rájuk lehet szűrni szín szerint. Ha viszont nincsenek, akkor a lenti megoldás hasznodra válhat: ez a makró ugyanis az összes olyan cellát kijelöli, mely az általunk választott szín(ek)nek megfelel, legyen az háttér- vagy betűszín.
Kód működésének lépései:
– először jelöljük ki a tartományt a munkalapon. Ha nincs kijelölés: a kód az aktív munkalap használt tartományával (usedrange) dolgozik
– majd futtassuk a kódot: egy vagy több (adott színt tartalmazó) cellát is választhatunk a CTRL billentyű lenyomásával
– válasszuk ki, hogy a kijelölt szín(eke)t háttérszínként vagy betűszínként akarjuk használni
– a kód kijelöli az összes olyan cellát, mely az általunk választott szín(eke)t tartalmazza
Az adott munkafüzetbe szúrjunk be egy modult a Visual Basic szerkesztőjében és az alábbi kódot másoljuk bele vagy az egyéni makró munkafüzethez (Personal.xlsb-hez) is hozzáadhatjuk:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
Sub CellakKijeloleseHatterszinVagyBetuszinAlapjan_02() Dim Tart As Range, Szin As Range, Cella As Range, TartUnio As Range Dim D As Object, X, i As Long, Valasz As String, MitVizsgal As Double 'Készítette: XLMotyo (https://xlmotyo.hu) 'a makró az összes olyan cellát kijelöli, mely az általunk választott szín(ek)nek megfelel, legyen az háttér- vagy betûszín 'Kód mûködésének lépései: '- elõször jelöljük ki a tartományt az adott munkalapon. Ha nincs kijelölés: 'a kód az aktív munkalap használt tartományával (usedrange) dolgozik '- majd futtassuk a kódot:egy vagy több (adott színt tartalmazó) cellát is választhatunk a CTRL billentyû lenyomásával '- válasszuk ki, hogy a kijelölt szín(eke)t háttérszínként vagy betûszínként akarjuk használni '- a kód kijelöli az összes olyan cellát, mely az általunk választott szín(eke)t tartalmazza Set D = CreateObject("scripting.dictionary") 'ellenõrizzük, hogy munkalapon (worksheet) vagyunk-e If TypeName(Selection) <> "Range" Then MsgBox "Válasszuk ki a kívánt szín(eke)t tartalmazó cellá(ka)t egy munkalapon!", vbExclamation, "Nem munkalap" Exit Sub End If '"Tart" nevû tartomány beállítása. Ha a makró futtatása elõtt nincs kijelölés a munkalapon: 'a "Tart" az aktív munkalap használt tartománya (usedrange) lesz If Selection.Count = 1 Then Set Tart = ActiveSheet.UsedRange Else Set Tart = Selection End If 'Kijelöljük a kívánt színeket az azokat tartalmazó cellákra való kattintással. 'Több ilyen cellát is választhatunk a CTRL billentyû lenyomásával On Error GoTo Vege Set Szin = Application.InputBox("Válasszuk ki a kívánt szín(eke)t tartalmazó cellá(ka)t!", _ "Több cella kijelölése: CTRL billentyû lenyomása", , , , , , 8) On Error GoTo 0 Application.ScreenUpdating = False 'eldönteni, hogy a háttér- vagy betûszínt tartalmazó cellákat akarjuk-e a makróval kijelöltetni? Valasz = MsgBox("A kiválasztott szín(ek) legyen(ek):" & vbNewLine & _ "háttérszín(ek): ez esetben a 'Yes' gombot válaszd vagy" & vbNewLine & _ "betûszín(ek): ez esetben a 'No' gombot válaszd?", vbYesNo + vbQuestion, "Háttér- vagy betûszín") 'az általunk kijelölt (színeket tartalmazó) celláknál:háttér- illetve betûszínek eltárolása a D nevû Dictionary objektumban If Valasz = vbYes Then For Each Cella In Szin.Cells D(Cella.Interior.Color) = "" 'háttérszínek eltárolása Next Cella Else For Each Cella In Szin.Cells D(Cella.Font.Color) = "" 'betûszínek eltárolása Next Cella End If X = D.keys 'a munkalapon lévõ tartomány celláit összevetjük az általunk korábban kijelölt (színeket tartalmazó) cellákkal For Each Cella In Tart.Cells 'a munkalapon lévõ tartomány celláinál: háttérszínek vagy betûszínek eltárolása a "MitVizsgal" változóban If Valasz = vbYes Then MitVizsgal = Cella.Interior.Color 'háttérszínek ElseIf Valasz = vbNo Then MitVizsgal = Cella.Font.Color 'betûszínek End If '"TartUnio"-ban eltároljuk a háttérszíneket/betûszíneket tartalmazó cellákat For i = 0 To D.Count - 1 If MitVizsgal = X(i) Then If TartUnio Is Nothing Then Set TartUnio = Cella Else Set TartUnio = Union(TartUnio, Cella) End If End If Next i Next Cella 'ha van(nak) a kritériumnak megfelelõ cella/cellák: kijelölés, egyébként hibaüzenet If Not TartUnio Is Nothing Then TartUnio.Select Else MsgBox "Nincs találat a kívánt szín(eke)t tartalmazó cellá(k)ra!", vbExclamation, "Nincs találat" End If Application.ScreenUpdating = True Vege: End Sub |
