Regelnummer toevoegen (berekend vanaf hoogste nummer)

[Tweety1]

Ik ben opzoek naar een macro die het volgende doet.
Op blad2 wil ik in kolom "R" een regelnummer toevoegen en doortrekken indien er meerdere nieuwe regels zijn op basis van het hoogste nummer op blad 1 (kolom AI).
De gegeven die in kolom B,E,F en G staan vormen de sleutel voor het zoeken op blad1.

In het voorbeeld bestand op blad2 staat de uitkomst zoals het moet zijn.

Mvg

Kasper

 

[HSV]

Bv.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sv, sv2, i As Long, ii As Long, r As Long, x As Long
r = Target.Row
If Application.CountA(Union(Cells(r, 2), Cells(r, 5), Cells(r, 6), Cells(r, 7))) = 4 Then
 Application.EnableEvents = False
  sv = Sheets(1).Cells(1).CurrentRegion
  sv2 = Sheets(2).Cells(1).CurrentRegion
    For i = 2 To UBound(sv)
     If Join(Array(Cells(r, 5), Cells(r, 2), Cells(r, 6), Cells(r, 7)), "") = sv(i, 2) & sv(i, 5) & sv(i, 6) & sv(i, 11) Then
       If x < sv(i, 35) Then x = sv(i, 35)
     End If
    Next i
    For ii = 2 To UBound(sv2)
     If Join(Array(Cells(r, 5), Cells(r, 2), Cells(r, 6), Cells(r, 7)), "") = sv2(ii, 5) & sv2(ii, 2) & sv2(ii, 6) & sv2(ii, 7) Then
       If x < sv2(ii, 18) Then x = sv2(ii, 18)
     End If
    Next ii
  Cells(r, 18) = x + 1
  Cells(r, 18).NumberFormat = String(Len(CStr(x + 1)) + 1, "0")
Application.EnableEvents = True
End If
End Sub

 

[Tweety1]

Ziet erg mooie uit alleen loop ik tegen het volgende aan.
Als ik meerdere cellen uit een andere Excel bestand knip en als waarde plakt in het Excel dan vult ie alleen de eerste regel aan met een regelnummer.
Eigenlijk wil ik nadat ik de gegevens in het Excel bestand hebt geplakt de regelnummers opnieuw vullen en rekening houdt met het hoogste nummer van blad 1.
Het Excel bestand waarin ik het wil verwerken begint bij regel 5 (Blad2).

 

[HSV]

Nieuwe poging.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sv, sv2, i As Long, ii As Long, x As Long, j As Long
 Application.EnableEvents = False
  sv = Sheets(1).Cells(1).CurrentRegion
  sv2 = Sheets(2).Cells(5, 1).CurrentRegion
   For j = Sheets(2).Cells(Rows.Count, 18).End(xlUp).Row + 1 To UBound(sv2) + 4
    If Application.CountA(Union(Cells(j, 2), Cells(j, 5), Cells(j, 6), Cells(j, 7))) = 4 Then
    For i = 2 To UBound(sv)
     If Cells(j, 5) & Cells(j, 2) & Cells(j, 6) & Cells(j, 7) = sv(i, 2) & sv(i, 5) & sv(i, 6) & sv(i, 11) Then
       If x < sv(i, 35) Then x = sv(i, 35)
     End If
    Next i
    For ii = 2 To j - 4
     If Cells(j, 5) & Cells(j, 2) & Cells(j, 6) & Cells(j, 7) = sv2(ii, 5) & sv2(ii, 2) & sv2(ii, 6) & sv2(ii, 7) Then
       x = x + 1
     End If
    Next ii
  Cells(j, 18) = x
  Cells(j, 18).NumberFormat = String(Len(CStr(x + 1)) + 1, "0")
  x = 0
  End If
  Next j
Application.EnableEvents = True
End Sub

 

[Tweety1]

Deze gaat beter alleen loopt de telling niet meer goed door als ik er een regel tussenuit haal.
Is het ook mogelijk een normale macro te gebruiken en niet macro die bij het tabblad hoort?
Dan kan ik het altijd opnieuw berekenen.

 

[HSV]

Sub hsv()
Dim sv, sv2, i As Long, ii As Long, x As Long, j As Long
sv = Sheets(1).Cells(1).CurrentRegion
With Sheets(2)
  sv2 = .Cells(5, 1).CurrentRegion
     For j = 2 To UBound(sv2)
      If Application.CountA(Array(sv2(j, 2), sv2(j, 5), sv2(j, 6), sv2(j, 7))) = 4 Then
      For i = 2 To UBound(sv)
       If sv2(j, 5) & sv2(j, 2) & sv2(j, 6) & sv2(j, 7) = sv(i, 2) & sv(i, 5) & sv(i, 6) & sv(i, 11) Then
         If x < sv(i, 35) Then x = sv(i, 35)
       End If
      Next i
      For ii = 2 To j
         If sv2(j, 5) & sv2(j, 2) & sv2(j, 6) & sv2(j, 7) = sv2(ii, 5) & sv2(ii, 2) & sv2(ii, 6) & sv2(ii, 7) Then
           x = x + 1
         End If
      Next ii
     sv2(j, 18) = String(Len(CStr(x + 1)), "0") & x
    End If
    x = 0
    Next j
  .Cells(5, 1).Resize(UBound(sv2), UBound(sv2, 2)) = sv2
 End With
End Sub

Kan ook in de Change event van Blad2.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sv, sv2, i As Long, ii As Long, x As Long, j As Long
sv = Sheets(1).Cells(1).CurrentRegion
Application.EnableEvents = False
  sv2 = Cells(5, 1).CurrentRegion
     For j = 2 To UBound(sv2)
      If Application.CountA(Array(sv2(j, 2), sv2(j, 5), sv2(j, 6), sv2(j, 7))) = 4 Then
      For i = 2 To UBound(sv)
       If sv2(j, 5) & sv2(j, 2) & sv2(j, 6) & sv2(j, 7) = sv(i, 2) & sv(i, 5) & sv(i, 6) & sv(i, 11) Then
         If x < sv(i, 35) Then x = sv(i, 35)
       End If
      Next i
      For ii = 2 To j
         If sv2(j, 5) & sv2(j, 2) & sv2(j, 6) & sv2(j, 7) = sv2(ii, 5) & sv2(ii, 2) & sv2(ii, 6) & sv2(ii, 7) Then
           x = x + 1
         End If
      Next ii
     sv2(j, 18) = String(Len(CStr(x + 1)), "0") & x
    End If
    x = 0
    Next j
  Cells(5, 1).Resize(UBound(sv2), UBound(sv2, 2)) = sv2
 Application.EnableEvents = True
End Sub

 

[Tweety1]

Thanks het werkt.