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

• #47859 Fferi50 Topikgazda ny.erno #47856

  Új Válasz 2021-11-23 22:34:34 #47859

  Ú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 #47856 üzenetére

  Szia!
  Íme:
  Sub valogato()
Dim a, x As Long, y As Long, u As String, d, v As String
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 y - 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
Else
If a(x, 1) <> d Then v = v & ";" & a(x, 1)
End If
DoEvents
If x Mod 1000 = 0 Then Application.StatusBar = "Készen van eddig " & x
Next
If a(x, 1) <> d Then v = v & ";" & a(x, 1)
Debug.Print "Keresés vége:" & Time
u = Mid(u, 2): v = Mid(v, 2)
a = Application.Transpose(Split(u, ";"))
Range("M1:M" & UBound(a)).Value = a
a = Application.Transpose(Split(v, ";"))
Range("F1:F" & UBound(a)).Value = a
Debug.Print "Visszaírás vége: " & Time
Application.StatusBar = False
MsgBox "Készen vagyunk"
End Sub
  Az F oszlopba írja ki az ismétlődés nélküli értékeket.
  Üdv.

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