Rychlejší vyhledání a zápis?

[junis]

Ahoj. Mistři, nešlo by tento zápis upravit? Pokud mám velké množství záznamů , tak je to pomalé. Dík


Public Sub jedinecneHodnoty()

Worksheets("RK").Range("K:K").ClearContents
Dim hodnoty As Variant
hodnoty = Worksheets("Datovepole").Range("C4:C200003").value

Dim jedinecne As New Collection
Dim hodnota As Variant, jedinecna As Variant
Dim obsahuje As Boolean
For Each hodnota In hodnoty
obsahuje = False
For Each jedinecna In jedinecne
If hodnota = jedinecna Then obsahuje = True
Next jedinecna
If obsahuje = False Then jedinecne.Add hodnota
Next hodnota

Dim i As Long
For i = 1 To jedinecne.Count
Worksheets("RK").Range("K" & i).value = jedinecne(i)
Next i


End Sub

[Reklama]

[elninoslov]

Kód: Vybrat vše

Public Sub jedinecneHodnoty()
Dim colJedinecne As New Collection
Dim Hodnoty(), Jedinecne()
Dim i As Long

    Worksheets("RK").Range("K:K").ClearContents
    Hodnoty = Worksheets("Datovepole").Range("C4:C200003").Value

    On Error Resume Next
    For i = 1 To UBound(Hodnoty, 1)
        If LenB(Hodnoty(i, 1)) > 0 Then colJedinecne.Add Hodnoty(i, 1), CStr(Hodnoty(i, 1))
    Next i
    On Error GoTo 0

    If colJedinecne.Count > 0 Then
        ReDim Jedinecne(1 To colJedinecne.Count, 1 To 1)
        For i = 1 To colJedinecne.Count
            Jedinecne(i, 1) = colJedinecne(i)
        Next i
        Worksheets("RK").Range("K1").Resize(colJedinecne.Count).Value = Jedinecne
    End If
   
End Sub

EDIT:
Toto je ešte rýchlejšie

Kód: Vybrat vše

Public Sub jedinecneHodnoty2()
Dim colJedinecne As New Collection
Dim Hodnoty(), Jedinecne()
Dim i As Long, J As Long

    Worksheets("RK").Range("K:K").ClearContents
    Hodnoty = Worksheets("Datovepole").Range("C4:C200003").Value
    ReDim Jedinecne(1 To UBound(Hodnoty, 1), 1 To 1)
   
    On Error Resume Next
    For i = 1 To UBound(Hodnoty, 1)
        If LenB(Hodnoty(i, 1)) > 0 Then
            colJedinecne.Add True, CStr(Hodnoty(i, 1))
            If Err.Number = 0 Then J = J + 1: Jedinecne(J, 1) = Hodnoty(i, 1) Else Err.Clear
        End If
    Next i
    On Error GoTo 0

    If J > 0 Then Worksheets("RK").Range("K1").Resize(J).Value = Jedinecne
   
End Sub

[junis]

Zkusil jsem tu druhou verzi.
Naprosto úžasné. Vše proběhlo v momentě.
Elnino Děkuji jsi frajer. Beru tě na fórech za optravdu největšího borce. Nechci nijak osočit ostatní, a všem se omlouvám, ale asi to tak bude.
Moc mi to pomohlo.