Új hozzászólás Aktív témák

• #47849 Fferi50 Topikgazda ny.erno #47843

  Új Válasz 2021-11-23 12:31:35 #47849

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz ny.erno #47843 üzenetére

  Szia!
  Akkor próbáljuk meg makróval:
  Sub valogato()
Dim a, x As Long, y As Long, u As String, d
ActiveSheet.UsedRange.Columns("A").Copy Range("D1")
y = ActiveSheet.UsedRange.Rows.Count
Debug.Print "sort indul:" & Time
With Range("D1:D" & y)
.Sort key1:=Range("D1"), Header:=xlNo
Debug.Print "sort vége:" & Time
a = .Value
End With
u = ""
Debug.Print "Keresés indul: " & Time
d = ""
For x = 1 To 200000 - 1
If a(x, 1) = a(x + 1, 1) Then
If d = "" Then
u = u & ";" & a(x, 1): d = a(x, 1)
Else
If a(x + 1, 1) <> d Then u = u & ";" & a(x, 1): d = a(x, 1)
End If
End If
DoEvents
If x Mod 1000 = 0 Then Application.StatusBar = "Készen van eddig " & x
Next
Debug.Print "Keresés vége:" & Time
u = Mid(u, 2)
a = Application.Transpose(Split(u, ";"))
Range("M1:M" & UBound(a)).Value = a
Debug.Print "Visszaírás vége: " & Time
Application.StatusBar = False
MsgBox "Készen vagyunk"
End Sub
  A makró az aktív munkalap A oszlopát átmásolja a D oszlopba majd rendezi. Ezután válogatja ki az ismétlődő értékeket és beírja az M oszlopba.
  Az előrehaladást a státusz soron lehet követni (ez csak akkor látszik, ha a munkalap nézetben vagy).
  A VBA nézet Immediate lapjára kiírja az egyes műveletek végrehajtási idejét. Nekem ez 200000 sor esetén alig több, mint 1 perc volt.
  Üdv.

  [ Szerkesztve ]

Új hozzászólás Aktív témák