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

• #47861 Fferi50 Topikgazda ny.erno #47856

  Új Válasz 2021-11-24 08:59:10 #47861

  Ú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!
  Közben találtam egy makró nélküli megoldást is, de ehhez pár műveletet el kell végezni :
  1. Legyen az A oszlopnak fejléce - mondjuk Sorozatszám
  2. Beszúrás - kimutatás - új lapra
  Sorozatszám mező a Sorokhoz
  Sorozatszám mező az Érték területre - mennyiség Sorozatszám
  Elfogadható időn belül kész a kimutatás!
  3. Az egész kimutatást a végösszeg sor nélkül kijelölni - beillesztés értéket egy új területre az új lapon.
  4. Szűrő bekapcsolása az átmásolt adatokra
  5. Szűrő - csak az 1 bekapcsolva - az egyedi értékek lesznek. Sorozatszám másolás - irányított beillesztés értéket - oda, ahol látni szeretnéd az egyedi sorozatszámokat
  
  6. Szűrő - átállítás az 1 kivételével minden - az ismétlődő értékek maradnak. Sorozatszám másolás - irányított beillesztés - oda, ahol az ismétlődéseket szeretnéd látni.
  
  Kétszázezer sorral kevesebb ideig tartott, mint ide leírni!
  Persze usert ilyenre kérni nem lehet, tesztelem a hozzá kapcsolódó makrót, ha kész lesz felmásolom.
  Üdv.

• #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