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

Hur slår man upp och returnerar bakgrundsfärg tillsammans med uppslagsvärdet i Excel?

Antar att du har en tabell som visas nedan. Nu vill du kontrollera om ett angivet värde finns i kolumn A och sedan returnera motsvarande värde tillsammans med bakgrundsfärg i kolumn C. Hur uppnår du det? Metoden i artikeln kan hjälpa dig att lösa problemet.

Vlookup och returnera bakgrundsfärg med uppslagsvärde med användardefinierad funktion


Vlookup och returnera bakgrundsfärg med uppslagsvärde med användardefinierad funktion

Gör så här för att leta upp ett värde och returnera motsvarande värde tillsammans med bakgrundsfärg i Excel.

1. I kalkylbladet innehåller det värde du vill söka igenom, högerklicka på arkfliken och välj Visa kod från snabbmenyn. Se skärmdump:

2. I öppningen Microsoft Visual Basic för applikationer kopiera nedan VBA-kod till kodfönstret.

VBA-kod 1: Vlookup och returnera bakgrundsfärg med uppslagsvärdet

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. Klicka sedan Insert > Modulernaoch kopiera nedanstående VBA-kod 2 till modulfönstret.

VBA-kod 2: Vlookup och returnera bakgrundsfärg med uppslagsvärdet

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. När du har infogat de två koderna klickar du sedan på verktyg > Referenser. Kontrollera sedan Microsoft Script Runtime ruta i Referenser - VBAProject dialog ruta. Se skärmdump:

5. tryck på andra + Q för att avsluta Microsoft Visual Basic för applikationer och gå tillbaka till kalkylbladet.

6. Välj en tom cell intill uppslagsvärdet och ange sedan formeln =LookupKeepColor(E2,$A$1:$C$8,3) in i formelfältet och tryck sedan på Enter.

Anmärkningar: I formeln, E2 innehåller det värde du ska slå upp, $ A $ 1: $ C $ 8 är tabellområdet och antalet 3 betyder att motsvarande värde du kommer att returnera lokaliseras i den tredje kolumnen i tabellen. Ändra dem efter behov.

7. Fortsätt att välja den första resultatcellen och dra ner Fill Handle för att få alla resultat tillsammans med bakgrundsfärgen. Se skärmdump.


Relaterade artiklar:


De bästa Office-produktivitetsverktygen

Kutools för Excel löser de flesta av dina problem och ökar din produktivitet med 80%

  • återanvändning: Sätt snabbt i komplexa formler, diagram och allt som du har använt tidigare; Kryptera celler med lösenord; Skapa e-postlista och skicka e-post ...
  • Super Formula Bar (enkelt redigera flera rader med text och formel); Läslayout (enkelt läsa och redigera ett stort antal celler); Klistra in i filtrerat intervall...
  • Sammanfoga celler / rader / kolumner utan att förlora data; Delat cellinnehåll; Kombinera duplicerade rader / kolumner... Förhindra duplicerade celler; Jämför intervall...
  • Välj Duplicera eller Unikt Rader; Välj tomma rader (alla celler är tomma); Super Find och Fuzzy Find i många arbetsböcker; Slumpmässigt val ...
  • Exakt kopia Flera celler utan att ändra formelreferens; Skapa referenser automatiskt till flera ark; Sätt in kulor, Kryssrutor och mer ...
  • Extrahera text, Lägg till text, ta bort efter position, Ta bort mellanslag; Skapa och skriva ut personsökningstalsatser; Konvertera mellan celler innehåll och kommentarer...
  • Superfilter (spara och tillämpa filterscheman på andra ark); Avancerad sortering efter månad / vecka / dag, frekvens och mer; Specialfilter av fet, kursiv ...
  • Kombinera arbetsböcker och arbetsblad; Sammanfoga tabeller baserat på nyckelkolumner; Dela data i flera ark; Batchkonvertera xls, xlsx och PDF...
  • Mer än 300 kraftfulla funktioner. Stöder Office / Excel 2007-2021 och 365. Stöder alla språk. Enkel implementering i ditt företag eller organisation. Fullständiga funktioner 30 dagars gratis provperiod. 60 dagars pengarna tillbaka-garanti.
kte-flik 201905

Fliken Office ger ett flikgränssnitt till Office och gör ditt arbete mycket enklare

  • Aktivera flikredigering och läsning i Word, Excel, PowerPoint, Publisher, Access, Visio och Project.
  • Öppna och skapa flera dokument i nya flikar i samma fönster, snarare än i nya fönster.
  • Ökar din produktivitet med 50 % och minskar hundratals musklick för dig varje dag!
officetab botten
Sortera kommentarer efter
Kommentarer (34)
Klassad 5 av 5 · 1 betyg
Denna kommentar minimerades av moderatoren på webbplatsen
Hur ändrar jag den här koden för att den ska extrahera bakgrundsfärgen från ett annat ark?
Till exempel skulle jag vilja använda en VLOOKUP i blad 2, som extraherar data och bakgrundsfärg från blad 1.
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har exakt samma fråga! Alla råd skulle vara mycket uppskattade.
Denna kommentar minimerades av moderatoren på webbplatsen
Jag skulle också vilja VLOOKUP på blad 2 och extrahera data och bakgrundsfärg från blad 1
Denna kommentar minimerades av moderatoren på webbplatsen
Använd denna lilla modifiering av koden som lagts upp.


Public xDic som ny ordbok
Public strWB As String
Public strWS As String

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

strWB = LookupRng.Parent.Parent.Name '*** Kom ihåg arbetsboken där data och färg kommer ifrån
strWS = LookupRng.Parent.Name '*** Kom ihåg arbetsbladet varifrån data och färg kommer

Ställ in xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

Om xFindCell är ingenting då
CLookup = ""
xDic.Add Application.Caller.Address, ""
annars
CLookup = xFindCell.Offset(0, xCol - 1).Value
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
Änden Funktion

Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr As String
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
Om xKeys >= 0 Då
För I = 0 Till UBound(xDic.Keys)
xDicStr = xDic.Items(I)
Om xDicStr <> "" Då
Range(xDic.Keys(I)).Interior.Color = Application.Workbooks(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
annars
Range(xDic.Keys(I)). Interiör.Färg = xlIngen
End If
Nästa
Ställ in xDic = Ingenting
End If
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Är detta för att fixa ett fel i den ursprungliga koden eller är detta för att låta den slå upp från ett annat ark?
Denna kommentar minimerades av moderatoren på webbplatsen
Denna ändring av originalkoden låter dig göra vlookup med färg från ett arbetsblad till ett annat eller från en arbetsbok till en annan. Men den här koden måste placeras i TARGET-arbetsbladet snarare än i SOURCE-arbetsbladet som beskrevs i den ursprungliga koden. Det beror på att den ursprungliga koden bara fungerade i ett arbetsblad, så det var både källan och målet. Detta är inte en fix till den ursprungliga koden. Jag har precis lagt till kod så att du kan hämta från valfri arbetsbok/arbetsblad (källa) till ditt arbetsblad (mål). Originalkoden fungerade som programmeraren tänkt sig.
Denna kommentar minimerades av moderatoren på webbplatsen
hej, jag gjorde proceduren men jag kan inte ta med bakgrundsfärgen i det nya kalkylbladet, jag tvivlar på om jag satte in kommandot strWB och strWS på rätt sätt. Jag lade denna strWB = LookupRng.Reporte_Opcionales
strWS = LookupRng.Imprimir Reporte_Opcionales är namnet på min arbetsbok
Denna kommentar minimerades av moderatoren på webbplatsen
Jag tror att raderna är tänkta att vara följande (EXAKT):

strWB = LookupRng.Parent.Parent.Name

strWS = LookupRng.Parent.Name


Jag kom på detta för ungefär 4 månader sedan så jag minns inte exakt hur jag kom på det här, men du skulle inte byta ut den här koden med något annat.
Denna kommentar minimerades av moderatoren på webbplatsen
vad namnet i strWB har upprepat Parent.Parent ???? stämmer det?
tack på förhand.
Denna kommentar minimerades av moderatoren på webbplatsen
Bob, hjälp mig snälla, kolla koden? Jag är säker på att du kan fixa det eftersom det brigme bakgrundsfärgen från andra ark.

förresten koden som är för arbete i samma ark fungerar men jag måste ta med data från andra ark :(.

tack på förhand
greetengs från Monterrey México.
Denna kommentar minimerades av moderatoren på webbplatsen
Det här fungerar utmärkt, tack!
Klassad 5 av 5
Denna kommentar minimerades av moderatoren på webbplatsen
den här koden fungerar på samma ark, hur kan jag slå upp färg från ett ark till ett annat?
Denna kommentar minimerades av moderatoren på webbplatsen
Använd denna lilla modifiering av koden som lagts upp.


Public xDic som ny ordbok
Public strWB As String
Public strWS As String

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

strWB = LookupRng.Parent.Parent.Name '*** Kom ihåg arbetsboken där data och färg kommer ifrån
strWS = LookupRng.Parent.Name '*** Kom ihåg arbetsbladet varifrån data och färg kommer

Ställ in xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

Om xFindCell är ingenting då
CLookup = ""
xDic.Add Application.Caller.Address, ""
annars
CLookup = xFindCell.Offset(0, xCol - 1).Value
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
Änden Funktion

Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr As String
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
Om xKeys >= 0 Då
För I = 0 Till UBound(xDic.Keys)
xDicStr = xDic.Items(I)
Om xDicStr <> "" Då
Range(xDic.Keys(I)).Interior.Color = Application.Workbooks(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
annars
Range(xDic.Keys(I)). Interiör.Färg = xlIngen
End If
Nästa
Ställ in xDic = Ingenting
End If
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Bob! Koden fungerar dock, av någon anledning kopierar den värden från ark 2 till ark 1, men kopierar cellformateringen och lämnar den i ark 2... Det är svårt att förklara, men det delar i princip en åtgärd (kopiera text + kopieringsformatering) och klistra in den i cellen) i två. Vet du hur man får det att göra båda på ett ark? Tack!
Denna kommentar minimerades av moderatoren på webbplatsen
den här koden körs på samma ark men hur kan jag slå upp cellfärg från ett ark till ett annat ark i excel
Tack på förhand :)
Denna kommentar minimerades av moderatoren på webbplatsen
Använd denna lilla modifiering av koden som lagts upp.


Public xDic som ny ordbok
Public strWB As String
Public strWS As String

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

strWB = LookupRng.Parent.Parent.Name '*** Kom ihåg arbetsboken där data och färg kommer ifrån
strWS = LookupRng.Parent.Name '*** Kom ihåg arbetsbladet varifrån data och färg kommer

Ställ in xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

Om xFindCell är ingenting då
CLookup = ""
xDic.Add Application.Caller.Address, ""
annars
CLookup = xFindCell.Offset(0, xCol - 1).Value
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
Änden Funktion

Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr As String
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
Om xKeys >= 0 Då
För I = 0 Till UBound(xDic.Keys)
xDicStr = xDic.Items(I)
Om xDicStr <> "" Då
Range(xDic.Keys(I)).Interior.Color = Application.Workbooks(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
annars
Range(xDic.Keys(I)). Interiör.Färg = xlIngen
End If
Nästa
Ställ in xDic = Ingenting
End If
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har Windows för Mac, när jag kommer till steg 4 - det finns inget alternativ för Microsoft Scripting Runtime, finns det något annat jag bör välja?
Denna kommentar minimerades av moderatoren på webbplatsen
När jag öppnar fönstret Visa kod finns det ett fönster men det är inte tomt. Kan jag klistra in koden under texten som redan finns där eller hur öppnar jag en ny "tom sida" tack?
Denna kommentar minimerades av moderatoren på webbplatsen
Jag returnerar ett värde, men får inte färgen. använde ark-till-ark-koden, följde till ett T. Några idéer om varför jag inte får färgen?
Denna kommentar minimerades av moderatoren på webbplatsen
Finns det något sätt att ändra detta för att använda det som en Hlookup?
Denna kommentar minimerades av moderatoren på webbplatsen
god eftermiddag bob till dessa koder du kan ändra dem förutom färgen kalla mig samma färgformat och typsnitt som innehåller cellen

Tack
Denna kommentar minimerades av moderatoren på webbplatsen
detta fungerar bra i office 2010, men inte 2013-versionen. Finns det någon uppdatering av makrot?
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, Kan jag använda vlookup på färgceller utan data i dem
Denna kommentar minimerades av moderatoren på webbplatsen
Jag får den önskade cellfärgen men jag behöver också uppslagsvärdet eftersom det returnerar heltal istället för sträng
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har använt detta i Excel 2016 och endast data överförs från källa till mål....färg överförs inte. Tankar om vad problemet kan vara: Är det inkompatibilitet med Excel 2016? Tack. MT
Denna kommentar minimerades av moderatoren på webbplatsen
Det här var UNDERBART! följde stegen och det fungerar utmärkt! Tack!
Denna kommentar minimerades av moderatoren på webbplatsen
Jag har många poster, det tar för lång tid att bearbeta och koden fortsätter att köras även efter att den är klar. Snälla hjälp
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, jag har ett ark med 10,948 XNUMX rader, det tar lite tid att hämta informationen med färger, väntar fortfarande. Är detta normalt eller är det något fel?
Denna kommentar minimerades av moderatoren på webbplatsen
Hur jag gör
Denna kommentar minimerades av moderatoren på webbplatsen
Jag använder tider och datum från excel-rapporter för att skapa tidrapporter för våra anställda. Om det angivna datumet, till exempel, 2020/08/11 matchar datumet i nästa flikarray (som innehåller många celler med samma datum men olika tider) vill jag att den bara drar cellen fylld i orange som kommer att anges som 2020/08/11 7:45. Är detta möjligt?
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, Fungerar den här koden för Office 2016 och senare versioner?
Denna kommentar minimerades av moderatoren på webbplatsen
nej det återkommer inte färgen.
Denna kommentar minimerades av moderatoren på webbplatsen
Den här koden fungerar bra, förutom i cellerna som formeln matas in i får upp 0 när cellen den letar upp är tom, min fråga är hur får jag den att ignorera tomma celler och förhindrar att cellen formeln är i matas in a 0 , finns det några var i koden för att ange en =IFERROR funktion kanske ?
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Kyle,

Jag testade den här koden och den visar inte 0 när cellen den letar efter är tom.
Du kanske kan inkludera formeln i OM-funktionen, som visas nedan, för att förhindra att resultatet returneras 0.
=IF(B2="","",LookupKeepColor(E2,$A$1:$C$8,3))
Det finns inga kommentarer här ännu
Lämna dina kommentarer
Postar som gäst
×
Betygsätt detta inlägg:
0   Tecken
Föreslagna platser

Följ oss

Copyright © 2009 - www.extendoffice.com. | Alla rättigheter förbehållna. Drivs av ExtendOffice. | | Sitemap
Microsoft och Office-logotypen är varumärken eller registrerade varumärken som tillhör Microsoft Corporation i USA och / eller andra länder.
Skyddad av Sectigo SSL