Automatisch nieuwe rijen invoegen op basis van celwaarden

[bloemenglenn]

Hallo,

Ik heb me de hele dag te pletter gezocht naar soortgelijke macro's, maar helaas kwam ik bij geen enkele terecht die mijn wensen kon vervullen.

Probleemstelling:
Ik wil een bepaald aantal lege rijen toevoegen onder items in een lijst waarbij rekening moet gehouden worden met 2 cellen als criteria.
Als Kolom B = "1" en Als Kolom C = "OK", Dan voeg 5 nieuwe rijen toe
Als Kolom B = "2" en Als Kolom C = "NOK", Dan voeg 7 nieuwe rijen toe
Als Kolom B = "3" en Als Kolom C = "OK", Dan voeg 9 nieuwe rijen toe
...

Volgens mij kan dit niet zo moeilijk zijn, maar ik krijg het maar niet voor elkaar door gebrek aan kennis..

Zou iemand me alsjeblieft kunnen helpen? Alvast bedankt!

 

[tkint]

Beste,

Komt deze oplossing in de buurt?

 

[HSV]

Rijen invoegen doe je van onderen naar boven.

Bv.

Sub hsv()
Dim i As Long
With Sheets("blad1")
For i = .Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
  With .Cells(i, 3)
    Select Case LCase(.Value)
        Case Is = "ok"
          If .Offset(, -1) = 1 Then .Offset(1).Resize(5).EntireRow.Insert
          If .Offset(, -1) = 3 Then .Offset(1).Resize(9).EntireRow.Insert
        Case Is = "nok"
          If .Offset(, -1) = 2 Then .Offset(1).Resize(7).EntireRow.Insert
    End Select
   End With
  Next i
End With
End Sub

......of in de switch.

Sub hsv()
Dim i As Long, rw
With Sheets("blad1")
   For i = .Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
      rw = Switch(.Cells(i, 2) & .Cells(i, 3)= "1OK", 5, .Cells(i, 2) & .Cells(i, 3)= "3OK", 9, .Cells(i, 2) & .Cells(i, 3) = "2NOK", 7)
     If rw > 0 Then .Rows(i + 1).Resize(rw).Insert
   Next i
  End With
End Sub

 

[tkint]

@HSV,

Dat is nou het verschil tussen beide vba-codes : deze van een hobbyist (ik) en deze van een professional. Ik heb jouw code alvast gekopieerd en voorzien van commentaar. De manier waarop jij controleert welke waarde in kolom B staat, is voor mij totaal nieuw.

 

[gast0660]

Hier heb je er nog een

Sub dotchie()
 Dim lRow As Long
    For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 2 Step -1
    If Cells(lRow, "B") = "1" And Cells(lRow, "B").Offset(, 1) = "OK" Then Rows(lRow).EntireRow.Resize(5).Insert
    If Cells(lRow, "B") = "2" And Cells(lRow, "B").Offset(, 1) = "NOK" Then Rows(lRow).EntireRow.Resize(7).Insert
    If Cells(lRow, "B") = "3" And Cells(lRow, "B").Offset(, 1) = "OK" Then Rows(lRow).EntireRow.Resize(9).Insert
    Next lRow
End Sub

 

[HSV]

@tkint, Je zet mij weg als 'professional', maar ik kan er nog geen droog brood van kopen. :d
Ps. mocht je nog eens rijen moeten verwijderen, gebeurt dat ook van onderen naar boven.

@dotchie, waarden behoeven niet als tekst in de code te worden weergegeven, en 'entirerow' kan ook uit je code.

 

[VenA]

Ik zou de voorwaarden in een aparte tab zetten en deze inlezen in een array of anders de gegevens 'hard gecodeerd' in een array zetten.

Sub VenA()
Dim j As Long, ar
ar = Split("1_ok 3_ok 2_nok 5 9 7")
With Blad1
  For j = .Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
    On Error Resume Next
    .Cells(j, 3).Offset(1).Resize(ar(Application.Match(.Cells(j, 2) & "_" & .Cells(j, 3), ar, 0) + 2)).EntireRow.Insert
  Next j
End With
End Sub

 

[bloemenglenn]

Hier kom ik een heel eind mee verder! Hartelijk dank! :thumb: