Excel - porovnání dvou sloupců

[vetchy]

Dobrý den,
potřebuji poradit s porovnáním dvou sloupců v Excelu.

Ve sloupci B mám data (některé hodnoty se zde mohou opakovat). Ve sloupci C mám další data (opět se zde mohou různá data opakovat a můžu mít jiný počet dat než ve sloupci B).

Mou snahou je porovnat oba dva sloupce a vyloučit z nich položky, které jsou v obou dvou stejné. Např. když budu mít ve sloupci B hodnotu 1 3x a ve sloupci C pouze jednou, tak výsledkem porovnání bude, že ve sloupci A zůstane hodnota 1 2x a ve sloupci C nebude žádná.

Data v obou dvou sloupcích lze seřadit. Není podmínkou, aby výsledné porovnané sloupce byly opět B,C, ale pokud by to šlo, bylo by to lepší.

Navržený postup budu aplikovat na různě velé soubory dat (od pár údajů až po několik tisíc položek v každém ze sloupců).

Přikládám soubor s ukázkovými daty.

Poradí někdo? Už dlouho si s tím lámu hlavu.

Předem děkuji.

[navstevnik]

Resenim je procedura VBA.
V editoru VBA (Alt+F11) vloz do standardniho modulu nize uvedenou proceduru a zavolej v editoru VBA klavesou F5 nebo v listu nabidka Nastroje>Makro>Makra>....:

Kód: Vybrat vše

Option Explicit

Sub ClearContentsClls()
  Dim BlkA As Range, BlkB As Range
  Dim Cll As Range, CllClr As Range
  Dim CntA As Long, CntB As Long, CntClr As Long
  Dim CntTmp As Long, CllTmp As Variant

  With Worksheets("list1")
    Set BlkA = .Range("b3:b" & Cells(.Rows.Count, 2).End(xlUp).Row)
    Set BlkB = .Range("c3:c" & Cells(.Rows.Count, 3).End(xlUp).Row)
    For Each Cll In BlkA.Cells
      If Cll <> vbNullString Then
        With WorksheetFunction
          CntA = .CountIf(BlkA, Cll.Value)
          CntB = .CountIf(BlkB, Cll.Value)
        End With
        CntClr = CntA
        If CntA > CntB Then
          CntClr = CntB
        End If
        If CntClr > 0 Then
          CllTmp = Cll.Value
          With BlkA
            CntTmp = 0
            Set CllClr = .Find(CllTmp, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
            Do
              CllClr.ClearContents
              CntTmp = CntTmp + 1
              If CntTmp = CntClr Then Exit Do
              Set CllClr = .FindNext(CllClr)
            Loop
          End With
          With BlkB
            CntTmp = 0
            Set CllClr = .Find(CllTmp, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
            Do
              CllClr.ClearContents
              CntTmp = CntTmp + 1
              If CntTmp = CntClr Then Exit Do
              Set CllClr = .FindNext(CllClr)
            Loop
          End With
        End If
      End If
    Next Cll
  End With
  BlkA.Sort Key1:=Range(BlkA.Resize(1, 1).Address), Order1:=xlAscending, Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  BlkB.Sort Key1:=Range(BlkB.Resize(1, 1).Address), Order1:=xlAscending, Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  Set Cll = Nothing
  Set CllClr = Nothing
  Set BlkA = Nothing
  Set BlkB = Nothing
End Sub

Podle potreby v procedure uprav nazev listu a cast adresy (je vcetne hlavicek sloupcu) a cislo sloupce (A:A=1, B:B=2,...) pro definici adresy porovnavanych bloku:
...
With Worksheets("list1")
Set BlkA = .Range("b3:b" & Cells(.Rows.Count, 2).End(xlUp).Row)
Set BlkB = .Range("c3:c" & Cells(.Rows.Count, 3).End(xlUp).Row)
...

Testuj na kopii dat, nejsou osetreny chybove stavy vznikle v dusledku nespravneho zadani adres.

[vetchy]

Ahoj,
díky moc za dané makro. Zatím jsem je vyzkoušel na dvou různých souborech a vždy to udělalo přesně to, co jsem potřeboval.
Jelikož tuto operaci budu používat docela často ušetří mi to moc práce a času, takže ještě jednou díky.

// Označuji za vyřešené.
// mike007