Zoek naar de voorlaatste regel/cel

[tonndejong]

Ik wil 3 cellen omlaag kopiëren, tot de eerstvolgende gevulde cel -1.
Ik gebruik daar voor Relative verwijzing toepassen.
En heb een Macro gemaakt, maar deze overschrijft ook de eerstvolgende gevulde cellen en dat is niet de bedoeling. Bijgaande de gebruikte macro.

Sub Macro1()
'
' Macro1 Macro
'

'
Range(Selection, Selection.End(xlDown)).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Range("A1:C1").Select
Selection.Copy
ActiveCell.Offset(1, 0).Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Range("A1").Select

End Sub

Wie kan mij helpen?
met vriendelijke groeten,
Tonn de Jong

 

[edmoor]

Laat eens in een voorbeeld documentje zien wat precies je bedoeling is want die code is niet te volgen.

 

[tonndejong]

Bijgevoegd bestand test.xls en test.xlsm

Het zijn de eerste 3 kolommen van een breder document.
Ik wil iedere keer 3 cellen a-b-c selecteren en kopiëren tot de eerst volgende volle cel

In kolom E-F-G is het zelfde als kolom A-B-C dit ter controle

Met Ctrl-s start je de macro

 

[sylvester-ponte]

het zou handig zijn als je ook laat zien hoe het er voor en na de macro uit moet zien.

 

[tonndejong]

Tot regel 114, zo zou het moeten worden.

 

[cow18]

Sub testing()
     With Selection                                             'met de huidige selectie van 1 rij bij 3 kolommen
          If .Rows.Count > 1 Then MsgBox "meer dan een rij", vbCritical: Exit Sub     'je mmoet binnen een rij blijven
          If .Columns.Count <> 3 Then MsgBox "geen 3 kolommen", vbCritical: Exit Sub     'het mogen maar 3 cellen zijn
          If IsEmpty(.Cells(2, 1)) Then MsgBox "de volgende regel is leeg", vbCritical: Exit Sub     'volgende rij mag niet leeg zijn

          Set c1 = .Cells(1).End(xlDown)                        'laatst gevulde cel onder die selectie, volgende is een lege
          Set c2 = .Cells(1).End(xlDown).End(xlDown)            'eerstvolgende niet-lege cel in die kolom
          If c2.Row <> c1.Row Then c1.Offset(1).Resize(c2.Row - c1.Row - 1, 3).Value = .Value     'indien niet laatste cel van werkblad, dan waarden overnemen
     End With
End Sub

 

[cow18]

de bijlage is een klein beetje anders
Ga dus binnen een gevuld bereik staan en laat die macro lopen

Sub testing()
     Do
          With Selection.CurrentRegion                          'met de huidige selectie van 1 rij bij 3 kolommen
               Set c = .Rows(.Rows.Count)
               Set c1 = c.Cells(1).End(xlDown)                  'laatst gevulde rij van currentregion
               If c.Row <> c1.Row And c1.Row <> Rows.Count Then c.Offset(1).Resize(c1.Row - c.Row - 1, c.Columns.Count).Value = c.Value     'indien niet laatste cel van werkblad, dan waarden overnemen
          End With
          Application.Goto c1, 1
     Loop While c1.Row <> Rows.Count
End Sub

eigenlijk kan het net zo gemakkelijk met vullen van de lege cellen met een formule en dan de formule vervangen door de waarde

Sub Met_Formules()
     On Error Resume Next
     Set c = Range("e1:G910").SpecialCells(xlBlanks)
     On Error GoTo 0

     If c Is Nothing Then MsgBox "einde verhaal", vbCritical: Exit Sub
     With c
          .FormulaR1C1 = "=+R[-1]C"
          .Value = .Value
     End With
End Sub

 

[tonndejong]

Ik heb de code in een macro gezet.
Deze werkt deels.

Er wordt steeds gekopieerd, de cellen welke geselecteerd zijn. Het zou moeten zijn de laatste regel 3 cellen.

En is het mogelijk om de lijst ook mee te laten scrollen, zodat je beter zicht houdt wat de macro doet lager in de lijst?

 

[cow18]

Sub testing()
     Do
          With Selection.CurrentRegion                          'met de huidige selectie van 1 rij bij 3 kolommen
               Set c = .Rows(.Rows.Count)
               Set c1 = c.Cells(1).End(xlDown)                  'laatst gevulde rij van currentregion
               If c.Row <> c1.Row And c1.Row <> Rows.Count Then
                    Application.Goto c, 1'ga in de laatste rij staan
                    MsgBox "kopieer : " & c.Address & vbLf & "naar      : " & c.Offset(1).Resize(c1.Row - c.Row - 1, c.Columns.Count).Address
                    c.Offset(1).Resize(c1.Row - c.Row - 1, c.Columns.Count).Value = c.Value     'indien niet laatste cel van werkblad, dan waarden overnemen
               MsgBox "klaar"'nu kan je de aanpassing zien
               End If
          End With
     Loop While c1.Row <> Rows.Count
End Sub

 

[tonndejong]

Tot zover bedankt. Nog een goed 2022 toegewenst.

Wanneer ik de code in een nieuw Excel-sheet opneem, werkt deze niet meer.

Hoe kan ik de laatste code welke je gemaakt hebt stoppen?
Kan ik deze code op 1 kolom los laten? Of wat moet deze dan aangepast worden?

met vriendelijke groet Tonn

 

[cow18]

Stoppen van de macro
je krijgt nu 2 keer een messagebox, een keer voor en een keer na het kopieren.
Je kan dan een CTRL+BREAK doen en "beëindigen" aanklikken in het daaropvolgende venster.

Je moet ook weten dat end(xldown) of de vergelijkbare manuele versie CTRL+pijltje omlaag anders reageert bij verborgen (=gefilterde) rijen, die worden niet in rekening gebracht.
Dus moet vooraf de filter verwijderd worden ?

Met "specialcells" zit je vast aan een "UsedRange" en zal bijvoorbeeld het laatste blokje niet afgewerkt worden.

Het maakt het een beetje moeilijk om een all-round oplossing te maken, die zich, in alle denkbare omstandigheden, altijd netjes gedraagd.

volgende poging

Sub testing()
     Set c = Selection
     Do
          With c
               If .Rows.Count > 1 Then MsgBox "1 rij !!!", vbInformation: Exit Sub

               Set c0 = Range(.Cells(1), .Cells(1).End(xlDown))     'bereik vanaf de huidige cel tot aan de cel die beeikt wordt door CTRL+pijltje omlaag te klikken
               If c0.Rows.Count <> WorksheetFunction.CountA(c0) Then MsgBox "foutje bedankt," & vbLf & "je staat misschien in de laatste rij van een bereik", vbInformation: Exit Sub     'zijn het allemaal gevulde cellen, dan is het oké, anders stoppen
               Set c1 = c0.Cells(c0.Rows.Count, 1)              'de laatste cel van c0
               Set c2 = c1.End(xlDown)                          'de daaropvolgende cel, die bereikt wordt door CTRL+pijltje omlaag

               If c2.Row <> c1.Row And c2.Row <> Rows.Count Then
                    Application.Goto c1, 1
                    MsgBox "huidige selectie : " & .Address & vbLf & vbLf & "kopieer : " & c1.Resize(, .Columns.Count).Address & vbLf & "naar      : " & c1.Offset(1).Resize(c2.Row - c1.Row - 1, .Columns.Count).Address
                    c1.Offset(1).Resize(c2.Row - c1.Row - 1, .Columns.Count).Value = c1.Resize(, .Columns.Count).Value     'indien niet laatste cel van werkblad, dan waarden overnemen
                    MsgBox "klaar"
               End If
          End With
     Loop While c1.Row <> Rows.Count
End Sub

 

[tonndejong]

Dank voor je hulp, ik kan hiermee uit de voeten.

Groetjes Tonn