Excel 2007-uprava kodu pro vyhledani a kopirovani duplicit

[David7]

Zdravim,
ve VBA jsem uplny zacatecnik a kod jsem skladal podle jinych uverejnenych kodu.

Makro mi funguje, ale pri velkem mnozsti radku je zdlouhave. Jakym zpusobem je mozno zminene makro upravit nebo zmenit tak, aby se zrychlilo?

Ve sloupci B a C vyhledavam duplicitni hodnoty (hodnoty jsou jedinecne) a tyto hodnoty vkladam do prislusnych radku sloupce D podle radku B - vysledkem ve sloupci D jsou duplicitni hodnoty a prazdne bunky. Sloupec D je pomocny, protoze jsem nevedel, jak jinak to udelat. Tento sloupec vubec nepotrebuji.
Pote provedu kopii hodnot ze sloupce D do sloupce H za sebe s vynechanim prazdnych bunek.

Dekuji za pripadne rady ci upravy.

Kód: Vybrat vše

Option Explicit

Sub kopie_dupl_hodnot2()

  'promenne pro vyhledani duplicitnich hodnot
  Dim data1 As Variant, data2 As Variant, x As Variant, y As Variant

  'promenne pro zjisteni polohy posledni bunky duplicitnich hodnot
  Dim WS As Worksheet
  Dim LastCell As Range
  Dim LastCellRowNumber As Long

  'promenne pro kopii a serazeni duplicitnich hodnot
  Dim i, j
  Dim kopirovat_co As Range, kopirovat_kam As Range
  
  Application.ScreenUpdating = False
  
  Sheets("list1").Activate
  
  Set WS = ActiveSheet
  
  With WS
    .Columns("D:D").ClearContents
    .Columns("H:H").ClearContents
    .Cells(3, 4) = "duplicita"
    .Cells(3, 8) = "datum"
  End With
  
    ' Nastavavení hodnoty data2 na rozsah pro porovnávání výběru.
    Set data2 = ActiveSheet.Range("C4", [C50000].End(xlUp))

    ' Projít všechny buňky data1 a porovnat s každou
    ' buňkou v data2.
    Set data1 = ActiveSheet.Range("B4", [B50000].End(xlUp))
    
    'zapsani duplicitnich hodnot do sloupce D
    'duplicitni hodnoty jsou vkladany do prislusneho radku do sloupce D podle sloupce B
    'pokud ve sloupci B neni duplicitni hodnota, do prislusneho radku ve sloupci D se vlozi prazdna bunka
    For Each x In data1
        For Each y In data2
            If x = y Then x.Offset(0, 2) = x
        Next y
    Next x
  
  'nastaveni kopirovani duplicitnich hodnot s vynechanim prazdnych bunek
  Set kopirovat_co = ActiveSheet.Range("D4")
  Set kopirovat_kam = ActiveSheet.Range("H4")
   
  'cislo posledniho radku ve sloupci D
  With WS
    Set LastCell = .Cells(.Rows.Count, "D").End(xlUp)
    LastCellRowNumber = LastCell.Row
  End With
  
  'kopie duplicitnich hodnot za sebe
  'ze sloupce D do sloupce H kopiruji jen bunky, ktere nejsou prazdne
  For i = 1 To LastCellRowNumber - 3
    If kopirovat_co.Offset(i - 1, 0).Value <> Empty Then
    kopirovat_kam.Offset(j, 0) = kopirovat_co.Offset(i - 1, 0).Value
    j = j + 1
    End If
  Next i
    
  Application.ScreenUpdating = True
  
End Sub