Note: The other languages of the website are Google-translated. Back to English
English English

Jak vlookup a vrátit barvu pozadí spolu s vyhledávací hodnotou v aplikaci Excel?

Předpokládejme, že máte tabulku uvedenou níže. Nyní chcete zkontrolovat, zda je zadaná hodnota ve sloupci A, a poté vrátit odpovídající hodnotu spolu s barvou pozadí ve sloupci C. Jak toho dosáhnout? Metoda v článku vám pomůže problém vyřešit.

Vlookup a návrat barvy pozadí s hodnotou vyhledávání pomocí uživatelem definované funkce


Vlookup a návrat barvy pozadí s hodnotou vyhledávání pomocí uživatelem definované funkce


Chcete-li vyhledat hodnotu a vrátit její odpovídající hodnotu spolu s barvou pozadí v aplikaci Excel, postupujte následovně.

1. V listu obsahuje hodnotu, kterou chcete vlookup, klepněte pravým tlačítkem na kartu listu a vyberte Zobrazit kód z kontextové nabídky. Viz snímek obrazovky:

2. V otvoru Microsoft Visual Basic pro aplikace zkopírujte níže uvedený kód VBA do okna Kód.

Kód VBA 1: Vlookup a vrátit barvu pozadí s vyhledávací hodnotou

Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long
    Dim xKeys As Long
    Dim xDicStr As String
    On Error Resume Next
    Application.ScreenUpdating = False
    xKeys = UBound(xDic.Keys)
    If xKeys >= 0 Then
        For I = 0 To UBound(xDic.Keys)
            xDicStr = xDic.Items(I)
            If xDicStr <> "" Then
                Range(xDic.Keys(I)).Interior.Color = _
                Range(xDic.Items(I)).Interior.Color
            Else
                Range(xDic.Keys(I)).Interior.Color = xlNone
            End If
        Next
        Set xDic = Nothing
    End If
    Application.ScreenUpdating = True
End Sub

3. Pak klikněte na tlačítko Vložit > Modula zkopírujte níže uvedený kód VBA 2 do okna modulu.

Kód VBA 2: Vlookup a vrátit barvu pozadí s vyhledávací hodnotou

Public xDic As New Dictionary
Function LookupKeepColor (ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
    Dim xFindCell As Range
    On Error Resume Next
    Set xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)
    If xFindCell Is Nothing Then
        LookupKeepColor = ""
        xDic.Add Application.Caller.Address, ""
    Else
        LookupKeepColor = xFindCell.Offset(0, xCol - 1).Value
        xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address
    End If
End Function

4. Po vložení dvou kódů klikněte na Tools > Reference. Poté zkontrolujte Microsoft Script Runtime pole v Reference - VBAProject dialogové okno. Viz snímek obrazovky:

5. zmáčkni Další + Q klávesy pro opuštění Microsoft Visual Basic pro aplikace okno a vrátit se zpět do listu.

6. Vyberte prázdnou buňku sousedící s vyhledanou hodnotou a poté zadejte vzorec =LookupKeepColor(E2,$A$1:$C$8,3) do řádku vzorců a poté stiskněte klávesu Enter.

Poznámka: Ve vzorci E2 obsahuje hodnotu, kterou vyhledáte, $ A $ 1: $ C $ 8 je rozsah tabulky a číslo 3 znamená, že odpovídající hodnota, kterou vrátíte, se najde ve třetím sloupci tabulky. Změňte je prosím podle potřeby.

7. Stále vybírejte první buňku s výsledky a přetažením rukojeti výplně dolů zobrazte všechny výsledky spolu s jejich barvou pozadí. Viz snímek obrazovky.


Související články:


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2019 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Kompletní funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50% a omezuje stovky kliknutí myší každý den!
officetab dno
Komentáře (32)
Hodnocení 5 z 5 · 1 hodnocení:
Tento komentář byl moderátorem webu minimalizován
Jak změním tento kód, aby extrahoval barvu pozadí z jiného listu?
Například bych chtěl použít SVYHLEDAT v Listu 2, který extrahuje data a barvu pozadí z Listu 1.
Tento komentář byl moderátorem webu minimalizován
Mám úplně stejnou otázku! Jakákoli rada by byla velmi oceněna.
Tento komentář byl moderátorem webu minimalizován
Také bych chtěl VLOOKUP na listu 2 a extrahovat data a barvu pozadí z listu 1
Tento komentář byl moderátorem webu minimalizován
Použijte tuto drobnou úpravu zveřejněného kódu.


Veřejný xDic jako nový slovník
Veřejné strWB jako řetězec
Veřejné strWS Jako řetězec

Funkce CLookup (ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
Dim xFindCell jako rozsah
On Error Resume Next

strWB = LookupRng.Parent.Parent.Name '*** Zapamatujte si sešit, ze kterého pocházejí data a barvy
strWS = LookupRng.Parent.Name '*** Pamatujte na pracovní list, ze kterého pocházejí data a barvy

Nastavit xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

Pokud xFindCell není nic, pak
Vyhledání = ""
xDic.Add Application.Caller.Address, ""
Jiný
CLookup = xFindCell.Offset(0, xCol - 1).Hodnota
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
End Function

Sub Worksheet_Change (ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr jako řetězec
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
Pokud xKeys >= 0 Pak
Pro I = 0 až UBound(xDic.Keys)
xDicStr = xDic.Items(I)
Pokud xDicStr <> "" Pak
Rozsah(xDic.Keys(I)).Interior.Color = Application.Sešity(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
Jiný
Rozsah(xDic.Keys(I)).Interior.Color = xlNone
End If
další
Nastavit xDic = nic
End If
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Jde o opravu chyby v původním kódu nebo o to, aby bylo možné vyhledat z jiného listu?
Tento komentář byl moderátorem webu minimalizován
Tato změna původního kódu vám umožňuje provádět vlookup w/color z jednoho listu do druhého nebo z jednoho sešitu do druhého. Ale tento kód je třeba umístit do listu TARGET spíše než do listu SOURCE, jak bylo popsáno v původním kódu. Je to proto, že původní kód fungoval pouze v jednom listu, takže to byl jak zdroj, tak cíl. Toto není oprava původního kódu. Právě jsem přidal kód, který vám umožní vytáhnout z libovolného sešitu/pracovního listu (zdroj) do vašeho listu (cíl). Původní kód fungoval tak, jak programátor zamýšlel.
Tento komentář byl moderátorem webu minimalizován
ahoj udělal jsem to podle postupu , ale nemůžu vnést barvu pozadí do nového listu , mám pochybnosti , jestli jsem dal správně příkaz strWB a strWS dal jsem to strWB = LookupRng.Reporte_Opcionales
strWS = LookupRng.Imprimir Reporte_Opcionales je název mého sešitu
Tento komentář byl moderátorem webu minimalizován
Věřím, že řádky by měly být následující (PŘESNĚ):

strWB = LookupRng.Parent.Parent.Name

strWS = LookupRng.Parent.Name


Přišel jsem na to asi před 4 měsíci, takže si přesně nepamatuji, jak jsem na to přišel, ale neměli jste tento kód nahradit ničím jiným.
Tento komentář byl moderátorem webu minimalizován
jaké jméno v strWB se opakuje Parent.Parent ???? je to správně?
díky předem.
Tento komentář byl moderátorem webu minimalizován
Bobe, pomozte mi, prosím, zkontrolujte kód? jsem si jistý, že to můžete opravit, protože to brigme barvu pozadí z jiného listu.

mimochodem kód, který je pro práci ve stejném listu, ale potřebuji přinést data z jiného listu :(.

díky předem
zdravím z Monterrey México.
Tento komentář byl moderátorem webu minimalizován
Funguje to skvěle, děkujeme!
Hodnocení 5 z 5
Tento komentář byl moderátorem webu minimalizován
tento kód pracuje na stejném listu, jak mohu vyhledat barvu z jednoho listu na druhý?
Tento komentář byl moderátorem webu minimalizován
Použijte tuto drobnou úpravu zveřejněného kódu.


Veřejný xDic jako nový slovník
Veřejné strWB jako řetězec
Veřejné strWS Jako řetězec

Funkce CLookup (ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
Dim xFindCell jako rozsah
On Error Resume Next

strWB = LookupRng.Parent.Parent.Name '*** Zapamatujte si sešit, ze kterého pocházejí data a barvy
strWS = LookupRng.Parent.Name '*** Pamatujte na pracovní list, ze kterého pocházejí data a barvy

Nastavit xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

Pokud xFindCell není nic, pak
Vyhledání = ""
xDic.Add Application.Caller.Address, ""
Jiný
CLookup = xFindCell.Offset(0, xCol - 1).Hodnota
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
End Function

Sub Worksheet_Change (ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr jako řetězec
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
Pokud xKeys >= 0 Pak
Pro I = 0 až UBound(xDic.Keys)
xDicStr = xDic.Items(I)
Pokud xDicStr <> "" Pak
Rozsah(xDic.Keys(I)).Interior.Color = Application.Sešity(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
Jiný
Rozsah(xDic.Keys(I)).Interior.Color = xlNone
End If
další
Nastavit xDic = nic
End If
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Bobe! Kód funguje, nicméně z nějakého důvodu zkopíruje hodnoty z Listu 2 do Listu 1, ale zkopíruje formátování buňky a nechá ho v Listu 2... Těžko se to vysvětluje, ale v podstatě rozdělí jednu akci (kopírování textu + tvorba kopírování a vložte jej do buňky) do dvou. Víte, jak to udělat, abyste udělali obojí na jednom listu? Děkuji!
Tento komentář byl moderátorem webu minimalizován
tento kód běží na stejném listu, ale jak mohu vyhledat barvu buňky z jednoho listu na jiný list v aplikaci Excel
Díky předem :)
Tento komentář byl moderátorem webu minimalizován
Použijte tuto drobnou úpravu zveřejněného kódu.


Veřejný xDic jako nový slovník
Veřejné strWB jako řetězec
Veřejné strWS Jako řetězec

Funkce CLookup (ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
Dim xFindCell jako rozsah
On Error Resume Next

strWB = LookupRng.Parent.Parent.Name '*** Zapamatujte si sešit, ze kterého pocházejí data a barvy
strWS = LookupRng.Parent.Name '*** Pamatujte na pracovní list, ze kterého pocházejí data a barvy

Nastavit xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

Pokud xFindCell není nic, pak
Vyhledání = ""
xDic.Add Application.Caller.Address, ""
Jiný
CLookup = xFindCell.Offset(0, xCol - 1).Hodnota
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
End Function

Sub Worksheet_Change (ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr jako řetězec
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
Pokud xKeys >= 0 Pak
Pro I = 0 až UBound(xDic.Keys)
xDicStr = xDic.Items(I)
Pokud xDicStr <> "" Pak
Rozsah(xDic.Keys(I)).Interior.Color = Application.Sešity(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
Jiný
Rozsah(xDic.Keys(I)).Interior.Color = xlNone
End If
další
Nastavit xDic = nic
End If
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Mám Windows pro Mac , když se dostanu ke kroku 4 - není zde žádná možnost pro Microsoft Scripting Runtime, je tu ještě něco, co bych měl vybrat?
Tento komentář byl moderátorem webu minimalizován
Když otevřu okno Zobrazit kód, je tam okno, ale není prázdné. Mohu prosím vložit kód pod text, který tam již je, nebo jak otevřít novou „prázdnou stránku“?
Tento komentář byl moderátorem webu minimalizován
Vracím hodnotu, ale nedostávám barvu. použil kód listu na list, následoval na T. Nějaké nápady, proč nedostávám barvu?
Tento komentář byl moderátorem webu minimalizován
Existuje nějaký způsob, jak to upravit pro použití jako Hlookup?
Tento komentář byl moderátorem webu minimalizován
dobré odpoledne bobe k těmto kódům můžete je změnit kromě barvy zavolejte mi stejný formát barvy a písmo, které obsahuje buňku

Děkuji
Tento komentář byl moderátorem webu minimalizován
to funguje dobře v Office 2010, ale ne ve verzi 2013. Existuje aktualizace makra?
Tento komentář byl moderátorem webu minimalizován
Ahoj, mohu použít vlookup na barevné buňky bez dat v nich
Tento komentář byl moderátorem webu minimalizován
Dostávám požadovanou barvu buňky, ale také potřebuji vyhledávací hodnotu, protože vrací celé číslo místo řetězce
Tento komentář byl moderátorem webu minimalizován
Použil jsem to v Excelu 2016 a ze zdroje do cíle se přenesou pouze data...... barva se nepřenese. Úvahy o tom, jaký problém by mohl být: Je to nekompatibilita s Excelem 2016? Dík. MT
Tento komentář byl moderátorem webu minimalizován
Tohle bylo ÚŽASNÉ! postupujte podle kroků a funguje to krásně! Děkuji!
Tento komentář byl moderátorem webu minimalizován
Mám mnoho záznamů, zpracování trvá příliš dlouho a kód běží i po dokončení. Prosím pomozte
Tento komentář byl moderátorem webu minimalizován
Dobrý den, mám list s 10,948 XNUMX řádky, natažení informací s barvami chvíli trvá, stále čekám. Je to normální, nebo je něco špatně?
Tento komentář byl moderátorem webu minimalizován
Jak udělám
Tento komentář byl moderátorem webu minimalizován
K vytváření pracovních výkazů pro naše zaměstnance používám časy a data z excelových reportů. Pokud se zadané datum, například 2020/08/11, shoduje s datem v poli dalších karet (které obsahuje mnoho buněk se stejným datem, ale různými časy), chci, aby vytáhlo pouze buňku vyplněnou oranžově, která bude uvedena jako 2020 08:11. Je to možné?
Tento komentář byl moderátorem webu minimalizován
Ahoj, funguje tento kód pro Office 2016 a novější verze?
Tento komentář byl moderátorem webu minimalizován
ne, nevrací barvu.
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění