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
