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

Jak porovnat dva řetězce pro podobnost nebo zvýraznit rozdíly v aplikaci Excel?

V některých případech možná budete muset pouze porovnat dvě sousední buňky řetězců a označit jejich podobnosti nebo rozdíly v aplikaci Excel. Tento článek poskytuje dvě metody, jak toho dosáhnout.

Porovnejte dva řetězce se vzorcem
Porovnejte dva řetězce pro podobnost nebo zvýrazněte rozdíly s kódem VBA


Porovnejte dva řetězce se vzorcem

Jak je ukázáno na níže uvedeném snímku obrazovky, pokud chcete vědět, zda jsou porovnávané řetězce shodné nebo ne, můžete použít následující vzorec.

1. Vyberte prázdnou buňku C2, zadejte vzorec = PŘESNÉ (A2; B2) do řádku vzorců a poté stiskněte klávesu Enter. Viz snímek obrazovky:

Poznámka: Ve vzorci jsou A2 a B2 buňky obsahující porovnávací řetězce.

2. Pokračujte ve výběru výsledné buňky a poté přetáhněte rukojeť Vyplnění do buněk, dokud nezískáte všechny porovnávané výsledky.

Výsledek FALSE znamená, že porovnávané řetězce jsou odlišné a výsledek TRUE označuje, že dva porovnávané řetězce jsou shodné. Viz snímek obrazovky:


Porovnejte dva řetězce pro podobnost nebo zvýrazněte rozdíly s kódem VBA

Pokud chcete porovnat dva řetězce a zvýraznit podobnosti nebo rozdíly mezi nimi. Následující kód VBA vám může pomoci.

1. lis Další + F11 současně otevřete Microsoft Visual Basic pro aplikace okno.

2. V Microsoft Visual Basic pro aplikace okno, klepněte na tlačítko Vložit > Modul. Poté zkopírujte a vložte následující kód do okna Kód.

Kód VBA: Porovnejte dva řetězce sloupců pro podobnost nebo zvýrazněte rozdíly

Sub highlight()
    Dim xRg1 As Range
    Dim xRg2 As Range
    Dim xTxt As String
    Dim xCell1 As Range
    Dim xCell2 As Range
    Dim I As Long
    Dim J As Integer
    Dim xLen As Integer
    Dim xDiffs As Boolean
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg1 = Application.InputBox("Range A:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub
    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If
lTwo:
    Set xRg2 = Application.InputBox("Range B:", "Kutools for Excel", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub
    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If
    If xRg1.CountLarge <> xRg2.CountLarge Then
       MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Kutools for Excel"
       GoTo lTwo
    End If
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "Kutools for Excel") = vbNo)
    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic
    For I = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(I)
        Set xCell2 = xRg2.Cells(I)
        If xCell1.Value2 = xCell2.Value2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Len(xCell1.Value2)
            For J = 1 To xLen
                If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then Exit For
            Next J
            If Not xDiffs Then
                If J <= Len(xCell2.Value2) And J > 1 Then
                    xCell2.Characters(1, J - 1).Font.Color = vbRed
                End If
            Else
                If J <= Len(xCell2.Value2) Then
                    xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

3. zmáčkni F5 klíč ke spuštění kódu. Zaprvé Kutools pro Excel V dialogovém okně vyberte první sloupec textových řetězců, které potřebujete porovnat, a poté klikněte na OK .

4. Potom druhý Kutools pro Excel Zobrazí se dialogové okno, vyberte řetězce druhého sloupce a klikněte na OK .

5. V posledním Kutools pro Excel Pokud chcete porovnat řetězce s podobností, klikněte na dialogové okno Ano knoflík. Chcete-li zvýraznit rozdíly porovnávaných řetězců, klikněte na ikonu Ne knoflík. Viz screenshot:

Pak můžete vidět srovnávané výsledky, jak je uvedeno níže.


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-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné 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 snižuje stovky kliknutí myší každý den!
officetab dno
Komentáře (19)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
Vážený pane, mnohokrát vám děkuji za váš kód VBA. Je to velmi užitečné. Ve skutečnosti nemám žádné znalosti o kódování. Takže i když chci upravit malou část kódování podle mého požadavku, jsem bezradný, mám jeden požadavek na toto kódování, aby bylo efektivnější a uživatelsky přívětivější. Mohl bys mi prosím pomoct?? Hlavním cílem výše uvedeného kódování je najít a zvýraznit rozdíly mezi údaji ve dvou sloupcích pro snadnou orientaci. Toto kódování je však z hlediska cíle trochu komplikované. Protože bere v úvahu "mezery" mezi obsahem a zvýrazní všechna data, i když jsou řetězce stejné. Pokud tedy můžeme porovnat data bez mezer, můžeme filtrovat část zvýrazněných dat. Místo toho, aby se zvýraznily pouze ty řetězce, které si nejsou podobné, zvýrazní se celá data hned od prvního odlišného řetězce k datům až na konec buňky. Proto bych rád uzavřel svou žádost níže uvedenými 2 body. 1) prosím upravte kódování pro porovnání buněk bez ohledu na mezery 2) prosím upravte kódování tak, aby dokázalo zvýraznit pouze různé řetězce, ale ne zvýraznit celý para od prvního bodu jiného řetězce. Děkuji mnohokrát za pomoc. S pozdravem Surya
Tento komentář byl moderátorem webu minimalizován
mám stejnou žádost jako suryateja.
2) prosím upravte kódování tak, aby bylo možné zvýraznit pouze různé řetězce, ale ne zvýraznit celý para od prvního odlišného bodu řetězce.
Tento komentář byl moderátorem webu minimalizován
Dávka výše uvedeného kódu nefunguje, pokud některá buňka obsahuje vzorec.
Tento komentář byl moderátorem webu minimalizován
Děkuji!
Tento komentář byl moderátorem webu minimalizován
Potřebuji vědět, jak mohu identifikovat řetězce se stejným textovým formátem, abych mohl propojit účet se všemi těmito řetězci. Pokud mám například 1,000 042 buněk s různým obsahem, chci oddělit ty, které mají formát 00-XXX-XX-XNUMX, a propojit je s acct#.
Tento komentář byl moderátorem webu minimalizován
Ahoj
Jak zkopíruji sloupec 1 vedle sloupce 2, pokud se jedna nebo více položek ve sloupci 1 podobá / je identických s jednou nebo více položkami ve sloupci 2?
Je mi líto, ale nějakou dobu pracuji s Excelem VBA a nemohu najít odpověď na tuto otázku.
Předem děkuji za odpověď.
Tento komentář byl moderátorem webu minimalizován
Ahoj
Jak zkopíruji sloupec 1 vedle sloupce 2, pokud se jedna nebo více položek ve sloupci 1 podobá / je identických s jednou nebo více položkami ve sloupci 2?
Je mi líto, ale nějakou dobu pracuji s Excelem VBA a nemohu najít odpověď na tuto otázku.
Předem děkuji za odpověď.
Tento komentář byl moderátorem webu minimalizován
Velmi užitečný skript! dík
Tento komentář byl moderátorem webu minimalizován
Jak mohu získat rozdílové číslo mezi dvěma řetězci?

Příklad: "123456" a "213456" ==> 2 rozdíl
Tento komentář byl moderátorem webu minimalizován
chci jen poděkovat!
Tento komentář byl moderátorem webu minimalizován
Tak jsem doufal, že to bude fungovat. Zdá se, že porovnává celé buňky a nikoli znaky v buňkách. Pouhé srovnávání Candy v jedné cele s Andym v jiné nenachází žádné podobnosti. A když porovnám rozdíly, celé jméno Andy je zvýrazněno červeně.
Tento komentář byl moderátorem webu minimalizován
Za prvé.. DÍKY Extend Office lidé za dobrý kód!!

Zkuste tuto modifikaci. Jednoduše rozšíří smyčku kontroly podle znaků tak, aby zahrnovala formátování barvy písma, přidá výchozí „Černou“ a také porovná znaky s nejdelší ze dvou porovnávaných buněk.

Sub highlight()
    Dim xRg1 As Range
    Dim xRg2 As Range
    Dim xTxt As String
    Dim xCell1 As Range
    Dim xCell2 As Range
    Dim I As Long
    Dim J As Integer
    Dim xLen As Integer
    Dim xDiffs As Boolean
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg1 = Application.InputBox("Range A:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub
    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If
lTwo:
    Set xRg2 = Application.InputBox("Range B:", "Kutools for Excel", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub
    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If
    If xRg1.CountLarge <> xRg2.CountLarge Then
       MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Kutools for Excel"
       GoTo lTwo
    End If
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "Kutools for Excel") = vbNo)
    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic
    For I = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(I)
        Set xCell2 = xRg2.Cells(I)
        If xCell1.Value2 = xCell2.Value2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Application.WorksheetFunction.Max(Len(xCell1.Value2), Len(xCell2.Value2))
            For J = 1 To xLen
                xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbBlack
                If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then
                    If Not xDiffs Then
                        If J <= Len(xCell2.Value2) And J > 1 Then
                            xCell2.Characters(1, J - 1).Font.Color = vbRed
                        End If
                    Else
                        If J <= Len(xCell2.Value2) Then
                            xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                        End If
                    End If
                End If
            Next J
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
DĚKUJI! tohle jsem právě potřeboval!
Tento komentář byl moderátorem webu minimalizován
Abyste se vyhnuli problémům tohoto kódu s mezerami, které by měly být v hodnotě ASCII 32 nebo 160 (zejména pokud řetězec pochází z HTML), musíte zahrnout testovací řádek 46 do smyčky if endif, jak je uvedeno níže:
Pokud ne ((Asc(xCell1.Characters(J, 1).Text) = 32 Nebo Asc(xCell1.Characters(J, 1).Text) = 160) And (Asc(xCell2.Characters(J, 1).Text ) = 32 Nebo Asc(xCell2.Characters(J, 1).Text) = 160)) Potom
( řádek 46 If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then Exit For)
End If

Přesto děkuji za kód.
Tento komentář byl moderátorem webu minimalizován
Jak to mám správně přidat? Při pokusu o výměnu řádku 46 se zobrazuje chyba. Děkuji
Tento komentář byl moderátorem webu minimalizován
ve vašem příkladu jsou slova „lets try“ podobná, ale váš kód je nedokáže zvýraznit.
Tento komentář byl moderátorem webu minimalizován
Confrontando la cella VIA ROMA 1 con la cella VIA RROMA 1 il programma evidenzia in rosso sia RROMA che 1. Non si può fare in modo che evidenzi solo la lettera diversa e quindi R? Grazie
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Jak mohu upravit kód tak, aby porovnal 2 sloupce a zvýraznil rozdíly v obou sloupcích?
Např:
Sloupec 1
A1,A2,A3,A4: Zvýrazněte A1 a A3
Sloupec 2
A2,A4,A5,A6,A7: Highlight A5,A6,A7
Tento komentář byl moderátorem webu minimalizován
Ahoj Lalo,
Bylo by hezké, kdybyste mohli nahrát snímek obrazovky vašich dat a výsledku, který chcete získat.
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í

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL