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

• #45199 Delila_1 veterán zsolti_20 #45192

  Új Válasz 2020-10-31 11:43:11 #45199

  Ú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

  

  Delila_1

  veterán

  válasz zsolti_20 #45192 üzenetére

  Nem volt egyszerű, de végül sikerült.

  Sub Eredmeny()
Dim sorSzuro As Integer, sorEredm As Integer, db As Integer, csoport As Integer
Dim usorLista, x As Integer, elso As Integer, ucso As Integer, nev As String, van

sorEredm = 2: csoport = 1
usorLista = Range("D" & Rows.Count).End(xlUp).Row

Kezd:
elso = Application.Match(csoport, Columns(1), 0)
ucso = Application.Match(csoport, Columns(1))
db = 0
For x = elso To ucso
If Application.WorksheetFunction.CountIf(Columns(4), Cells(x, 2)) > 0 Then db = db + 1
If db = ucso - elso + 1 Then
For sorSzuro = 2 To usorLista
nev = Cells(sorSzuro, "D")
On Error Resume Next
van = Application.Match(nev, Range(Cells(elso, "B"), Cells(ucso, "B")), 0)
If VarType(van) = vbError Then
On Error GoTo 0
Else
Cells(sorEredm, "F") = csoport
Cells(sorEredm, "G") = nev
sorEredm = sorEredm + 1
End If
Next
End If
Next
csoport = csoport + 1
If csoport > Application.WorksheetFunction.Max(Columns(1)) Then
Exit Sub
Else
GoTo Kezd
End If
End Sub

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