bij meerdere gelijke cellen rijen verwijderen

[hoss312]

Best Forum,

Mijn vraag lijkt niet moeilijk maar ik kom er toch niet uit. Ik heb een groot aantal rijen met data. Als de naam (nummers in voorbeeld sheet) en start datum overeenkomen en de status is aangemaakt voor een rij en geannuleerd voor de andere rij wil ik beide rijen helemaal deleten. Eigenlijk +1 aangemaakt in een rij en -1 geannuleerd andere rij dus 0.

Zie mijn voorbeeld file. Status beëindigd moet dus blijven want dat was eerst status aangemaakt en is voltooid.

Alvast bedankt voor de hulp

MVG Hoss

 

[HSV]

Zo te zien zijn er maar twee rijen die daaraan voldoen; nl. rij 17 en 18.
Beiden 01-05-2020; de een Geannuleerd en de ander Aangemaakt.

Sub hsv()
Dim sv, a, i As Long, j As Long, s0 As String, s00 As String, s02 As String, s03 As String
sv = Sheets(1).Cells(1).CurrentRegion.Resize(, 9)
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(sv)
       s0 = sv(i, 2) & "|" & sv(i, 5)
        If .Exists(s0) Then
         If sv(i, 7) = "Aangemaakt" Or sv(i, 7) = "Geannuleerd" Then
            a = .Item(s0)
            a(8) = a(8) & i & " "
            a(9) = a(9) & sv(i, 7)
             If InStr(a(9), "GeannuleerdAangemaakt") Then s02 = a(8)
           .Item(s0) = a
         End If
           Else
            .Item(s0) = Application.Index(sv, i, 0)
             a = .Item(s0)
             a(8) = a(8) & i & " "
             a(9) = a(9) & sv(i, 7)
             .Item(s0) = a
        End If
      sv(i, 5) = Format(sv(i, 5), "dd/mm/yyyy  hh:mm:ss")
      sv(i, 6) = Format(sv(i, 6), "dd/mm/yyyy  hh:mm:ss")
     Next i
    s03 = Replace(Join(Application.Transpose(Evaluate("row(1:" & UBound(sv) & ")"))), s02, "")
    With Sheets(2)
     .Cells(1).Resize(UBound(sv) - UBound(Split(s02)), 7) = Application.Index(sv, Application.Transpose(Split(Trim(s03))), Array(1, 2, 3, 4, 5, 6, 7))
       For j = 5 To 6
         .Columns(j).TextToColumns .Cells(1, j), xlDelimited, , , -1, , , , , , Array(1, 2)
       Next j
       .Columns.AutoFit
    End With
 End With
End Sub

 

[HSV]

Bij nader inzien en geen aanpassing mogelijk in vorig schrijven.

Sub hsv()
Dim sv, sq, a, i As Long, j As Long, jj As Long, s0 As String, s02 As String, s03 As String
sv = Sheets(1).Cells(1).CurrentRegion.Resize(, 9)
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(sv)
       s0 = sv(i, 2) & "|" & sv(i, 5)
       If sv(i, 7) = "Aangemaakt" Or sv(i, 7) = "Geannuleerd" Then
          If .Exists(s0) Then
               a = .Item(s0)
            Else
               a = Application.Index(sv, i, 0)
            End If
            a(8) = a(8) & i & " "
            a(9) = a(9) & sv(i, 7)
             If InStr(a(9), "GeannuleerdAangemaakt") Then s02 = s02 & a(8)
               .Item(s0) = a
          End If
      sv(i, 5) = Format(sv(i, 5), "dd/mm/yyyy  hh:mm:ss")
      sv(i, 6) = Format(sv(i, 6), "dd/mm/yyyy  hh:mm:ss")
     Next i
     sq = Split(s02)
     For jj = 0 To UBound(sq)
        If s03 = "" Then
          s03 = Replace(Join(Application.Transpose(Evaluate("row(1:" & UBound(sv) & ")"))), sq(jj), "")
         Else
          s03 = Replace(s03, sq(jj), "")
        End If
    Next jj
    With Sheets(2)
     .Cells(1).Resize(UBound(Split(Application.Trim(s03))) + 1, 7) = Application.Index(sv, Application.Transpose(Split(Application.Trim(s03))), Array(1, 2, 3, 4, 5, 6, 7))
       For j = 5 To 6
         .Columns(j).TextToColumns .Cells(1, j), xlDelimited, , , -1, , , , , , Array(1, 2)
       Next j
       .Columns.AutoFit
    End With
 End With
End Sub