• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Lege rijen in kolom A toevoegen op celwaarden in kolom C

Status
Niet open voor verdere reacties.

hmwul

Gebruiker
Lid geworden
15 dec 2012
Berichten
430
Hopelijk kan iemand mij hiermee helpen.

Kolom A = Datum: van
Kolom B = Datum: tot
Kolom C = aantal toe te voegen rijen in kolom A

Voorbeeld:
Kolom A = Datum: 01-11-2021
Kolom B = Datum: 05-11-2021
Kolom C = 4

4 lege rijen toevoegen onder 01-11-2021

Resultaat in kolom A
01-11-2021
02-11-2021
03-11-2021
04-11-2021
05-11-2021

Zie bijlage.
Tabs Source en resultaten.

Op Internet gezocht, maar helaas niets kunnen vinden dat hierop lijkt.

Hartelijk dank bij voorbaat!

-

LATER
====

Probleem opgelost. Weliswaar niet echt netjes, maar okay.
Ik heb toch nog een macro gevonden - geeft weliswaar een foutmelding maar doet het wel. Wat de foutmelding inhoudt, geen idee. Screenupdating(??)

Macro

Code:
Sub InsertRows()
    Dim End_Row As Long, n As Long, Ins As Long
    End_Row = Range("C" & Rows.Count).End(xlUp).Row
    
    Application.ScreenUpdating = False
    For n = End_Row To 1 Step -1

        Ins = Cells(n, "C").Value

        If Ins > 0 Then Range("C" & n + 1 & ":C" & n + Ins).EntireRow.Insert

    Next n
    Application.ScreenUpdating = True
End Sub

Lege rijen worden toegevoegd
Dan onder de eerste lege cel staan, =a3+1, CTRL-C
Dan lege cellen in die kolom selecteren
Daarna CTRL-V

Zoals gezegd, het is allemaal niet zo fraai, maar gelukkig wel opgelost.

Ik post dit omdat anderen het misschien kunnen gebruiken in de toekomst.
De macro gaat uit dat de waarden in kolom C staan, staan die elders dan moet de macro aangepast worden.
 

Bijlagen

  • Rijen toevoegen 28112021.xlsx
    21,9 KB · Weergaven: 14
  • SnagIt-28112021 101020.png
    SnagIt-28112021 101020.png
    68,8 KB · Weergaven: 16
Laatst bewerkt:
Ins is gedeclareerd als een long.
De laatste loop van je macro is op rij 1, waarvan de C-cel "rij toevoegen" is, dus een tekst.
Dus die tekst kan niet in een long-variabele gestopt worden.
Ofwel had je die moeten afvangen, ofwel had je loop moeten stoppen op rij 2
 
zo kan je gemakkelijker meevolgen
Code:
Sub InsertRows()
     Dim End_Row As Long, n As Long, Ins As Long
     End_Row = Range("C" & Rows.Count).End(xlUp).Row

     'Application.ScreenUpdating = False 'scherm bevriezen ---> eventjes uitgezet
     For n = End_Row To 1 Step -1                               'loopje van de laatste tot de 2e rij
          Application.Goto Cells(n, "a"), 0                     'opdat je zou kunnen meevolgen, ga naar die cel
          Application.Wait Now + TimeSerial(0, 0, 1)            'wacht 1 sec
          If IsNumeric(Cells(n, "C").Value) Then                'aantal rijen invoegen is numeriek
               Ins = Cells(n, "C").Value                        'aantal in te voegen rijen
               If Ins > 0 Then
                    Range("C" & n + 1 & ":C" & n + Ins).EntireRow.Insert     'rijen invoegen op de rij er onder
                    Application.Wait Now + TimeSerial(0, 0, 1)  'wacht 1 sec
                  [COLOR="#FF0000"]  Cells(n , "a").AutoFill Cells(n , "a").Resize(Ins + 1)     'het "gat" aanvullen[/COLOR]
               End If
          End If
     Next n
     'Application.ScreenUpdating = True
End Sub
 
Laatst bewerkt:
deze doet het inclusief tussen datums
Code:
Sub test()
Dim Rr As Range, R As Range
Set Rr = [A1].CurrentRegion
For rij = Rr.Rows.Count To 2 Step -1
  Set R = Rr(rij, 1)
  If R(, 3) > 0 Then
      Range(R(R(, 3) + 1), R(2, 3)).Insert shift:=xlDown
      R.AutoFill Destination:=Range(R, R(R(, 3) + 1)), Type:=xlFillDefault
  End If
Next
End Sub
 
zo kan je gemakkelijker meevolgen
Code:
Sub InsertRows()
     Dim End_Row As Long, n As Long, Ins As Long
     End_Row = Range("C" & Rows.Count).End(xlUp).Row

     'Application.ScreenUpdating = False 'scherm bevriezen ---> eventjes uitgezet
     For n = End_Row To 1 Step -1                               'loopje van de laatste tot de 2e rij
          Application.Goto Cells(n, "a"), 0                     'opdat je zou kunnen meevolgen, ga naar die cel
          Application.Wait Now + TimeSerial(0, 0, 1)            'wacht 1 sec
          If IsNumeric(Cells(n, "C").Value) Then                'aantal rijen invoegen is numeriek
               Ins = Cells(n, "C").Value                        'aantal in te voegen rijen
               If Ins > 0 Then
                    Range("C" & n + 1 & ":C" & n + Ins).EntireRow.Insert     'rijen invoegen op de rij er onder
                    Application.Wait Now + TimeSerial(0, 0, 1)  'wacht 1 sec
                  [COLOR="#FF0000"]  Cells(n , "a").AutoFill Cells(n , "a").Resize(Ins + 1)     'het "gat" aanvullen[/COLOR]
               End If
          End If
     Next n
     'Application.ScreenUpdating = True
End Sub

Sorry voor de vertraging. Er kwamen een paar dingen tussendoor.

Hartelijk dank voor de nieuwe macro.

Ik heb bovenstaande code gebruikt. Werkt op zich perfect en vult automatisch de datums in.
Dat is handig, scheelt een hoop werk.

Er is een klein dingetje met de macro. Het -lijkt- alsof hij er lang over doet. Een paar keer geprobeerd - een paar minuten wachten.
Ging langzaam.
Heb toen doe de 'application.screenupdating' geactiveerd, apostrophe-jes verwijderd. Ik keek nog steeds zo'n 3-4 minuten tegen zandlopertje.
Er gebeurde niets.
Toen deed ik maar 'Esc'
De macro stopte tegelijk en alle regels waren toegevoegd. Het resultaat is okay, maar na enige tijd moet je even op Esc drukken.

Toen opnieuw geprobeerd, maar dan na 10 seconden op Esc gedrukt, het resultaat was okay.
Dat op 'Esc' drukken was de truc.

Hartelijk dank!

Later...

wacht even..

1) ik heb de application.wait regels geDEactiveerd (' ervoor) macronaam gewijzigd in InsertDateRows()
2) ik heb ook de regel : Cells(n , "a").AutoFill Cells... etc. gedeactiveerd en macronaam gewijzigd in InsertEmptyRows()

Beide werken als een speer. De een voegt automatisch datums toe, de andere kan handig zijn in andere gevallen.

Super! :thumb: :thumb:

Nogmaals hartelijk dank.
 
deze werkt sneller:
Code:
Sub test()
Dim Rr As Range
Set Rr = [A1].CurrentRegion
Temp = Rr
ReDim opl(1 To Rr.Rows.Count + WorksheetFunction.Sum(Rr.Columns(3)), 1 To Rr.Columns.Count)
For rij = 2 To Rr.Rows.Count
  p = p + 1
  opl(p, 1) = Temp(rij, 1)
  opl(p, 2) = Temp(rij, 2)
  opl(p, 3) = Temp(rij, 3)
  For n = opl(p, 1) + 1 To opl(p, 2)
    p = p + 1
    opl(p, 1) = opl(p - 1, 1) + 1
  Next
Next
[A2].Resize(UBound(opl, 1), UBound(opl, 2)) = opl
End Sub
 
zo kan je gemakkelijker meevolgen
die 2 * application.wait doet je voor iedere regel dus 1 (niet tussenvoegen) of 2 (wel tussenvoegen) sec wachten.
Dus die 2 regels mogen weg en die "application.goto" ook.

of de oplossing van sylvester, daar kan niets tegen op in snelheid !!!
enige voorwaarde, als er formules in dat bereik stonden, dan zijn ze weg, vervangen door hun waarde !
Het kan ook misgaan met datums of financiële waarden, dus in dat geval, misschien beter ".currentregion.value2" gebruiken bij het inlezen.
 
Laatst bewerkt:
Hier ook nog eentje:)

Code:
Sub jec()
 ar = Cells(1, 1).CurrentRegion.Value2
 ReDim jv(1, 0)
 
 For i = 2 To UBound(ar)
   For j = ar(i, 1) To ar(i, 2)
      ReDim Preserve jv(1, x)
      jv(0, x) = j
      jv(1, x) = IIf(j = ar(i, 1), ar(i, 2), "")
      x = x + 1
   Next
 Next
 Cells(2, 6).Resize(x, 2) = Application.Transpose(jv)
End Sub
 
Laatst bewerkt:
Iedereen hier, nogmaals hartelijk dank voor de oplossingen!

1. De reactie hier is supersnel
2. Altijd een goede oplossing

Echt top!

[Off topic] Heb overigens wel een 'probleempje' met macro's - of beter gezegd het 'beheer' ervan.
Zie aparte post. Getwijfeld of ik hier als een off-topic zaak zou posten, of apart.
Gekozen voor een aparte post.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan