Kopieren van een bepaalde rij

[Bas1980]

In excel heb ik een userform waarmee je met behulp van een combobox een naam in een bepaald worksheet kunt selecteren om vervolgens die gehele rij (die persoon met gegevens) te verwijderen. De database bestaat uit een kleine 1000 personen.
Wanneer ik een persoon heb geselecteerd kan ik deze met behulp van een knop uit de worksheet verwijderen. Nu ben ik op zoek naar een code die eerst de gehele rij naar een archief worksheet kopieert en dan pas de rij verwijdert. Iedere verwijderde persoon komt dus op een nieuwe rij in het archief te staan dus zal ook de eerstvolgende lege rij moeten worden geselecteerd.

Dit is de code die ik heb voor het verwijderen:

Private Sub Cmdverwijderen_Click()
Application.ScreenUpdating = False
If Trim(CBselect.Value) = "" Then
CBselect.SetFocus
MsgBox "Selecteer een beveiligingsmedewerker welke je wilt verwijderen!", vbExclamation, "Invoer vereist!"
Exit Sub
End If
cName = CBselect
response = MsgBox("Weet je zeker dat je " & cName & " uit de database wilt verwijderen?", vbOKCancel, "Beveiligingsmedewerker verwijderen")
If response = vbCancel Then
Exit Sub
End If
Dim blad As Worksheet
Set blad = Sheets("Database beveiligers")
If CBselect.ListIndex = -1 Then Exit Sub
blad.Rows(CBselect.ListIndex + 2).Delete
CBselect.Clear
UserForm_Initialize
MsgBox "" & cName & " is succesvol uit de database verwijderd.", vbInformation, "Succesvol verwijderd!"
ActiveWorkbook.Worksheets("Database beveiligers").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Database beveiligers").AutoFilter.Sort.SortFields. _
Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Database beveiligers").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Save
response = MsgBox("Wil je nog een beveiligingsmedewerker uit de database verwijderen?", vbYesNo, "Beveiligingsmedewerker verwijderen")
If response = vbNo Then
Unload Me
End If
End Sub


De naam van het archief ws = Archief beveiligers

Ik hoop dat jullie me kunnen helpen in deze

Groetjes Bas

 

[tkint]

Beste,

Bij dergelijke vragen hoort een voorbeeldbestand. Zelf een bestand opbouwen om de code uit te testen, is niet aan de orde.

 

[VenA]

Een beetje onleesbaar gebeuren wat te reduceren zal zijn naar een paar regels.

Als antwoord op de vraag eerst kopiëren en dan verwijderen

With blad.Rows(CBselect.ListIndex + 2)
  .Copy Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Offset(1)
  .Delete
End With

 

[Bas1980]

Een beetje onleesbaar gebeuren wat te reduceren zal zijn naar een paar regels.

Als antwoord op de vraag eerst kopiëren en dan verwijderen

With blad.Rows(CBselect.ListIndex + 2)
  .Copy Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Offset(1)
  .Delete
End With

Dank je! Deze werkt. Heb je toevallig ook nog de code om automatisch de datum en tijd in het archief er bij te zetten? Dat deze als extra toegevoegd kan worden en men op datum terug kan zoeken?

Groetjes Bas

 

[tkint]

@Bas1980

Wil je een voorbeeldbestand, met enkele testgegevens, publiceren? Jouw VBA-code interesseert mij want ik heb een gelijkaardige toepassing die ik niet werkende krijg.

 

[Bas1980]

Bijgevoegd.

Dus als iemand de datum nog n het archiefblad kan krijgen....

Groetjes Bas


Bekijk bijlage Map1.xlsm

 

[tkint]

Beste,

Het wil even niet lukken om de datum toe te voegen achteraan de gekopieerde rij. Maar het lukt mij wel.
Bedankt voor het gepubliceerde bestand.

 

[Bas1980]

Beste,

Het wil even niet lukken om de datum toe te voegen achteraan de gekopieerde rij. Maar het lukt mij wel.
Bedankt voor het gepubliceerde bestand.

Zie hem wel verschijnen

 

[VenA]

Probeer het zo eens

Private Sub UserForm_Initialize()
  CBselect.List = Sheets("Database beveiligers").Columns(1).SpecialCells(2).Offset(1).SpecialCells(2).Resize(, 4).Value
End Sub

Private Sub Cmdverwijderen_Click()
Application.ScreenUpdating = False
  If CBselect.ListIndex = -1 Then
    CBselect.SetFocus
    MsgBox "Selecteer een beveiligingsmedewerker welke je wilt verwijderen!", vbExclamation, "Invoer vereist!"
    Exit Sub
  End If
  If MsgBox("Weet je zeker dat je " & CBselect & " uit de database wilt verwijderen?", vbOKCancel, "Beveiligingsmedewerker verwijderen") = vbCancel Then Exit Sub
  
  With CBselect
    Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 5) = Array(.Column(0), .Column(1), .Column(2), .Column(3), Now)
  End With
  
  With Sheets("Database beveiligers")
    .Rows(CBselect.ListIndex + 2).Delete
    .Cells(1).CurrentRegion.Sort .[A1], , , , , , , True
    MsgBox "" & CBselect & " is succesvol uit de database verwijderd.", vbInformation, "Succesvol verwijderd!"
    CBselect.List = .Columns(1).SpecialCells(2).Offset(1).SpecialCells(2).Resize(, 4).Value
    CBselect.ListIndex = -1
  End With
 ActiveWorkbook.Save
 If MsgBox("Wil je nog een beveiligingsmedewerker uit de database verwijderen?", vbYesNo, "Beveiligingsmedewerker verwijderen") = vbNo Then Unload Me
End Sub

 

[tkint]

Beste,

Ik heb na de kopieer-code van VenA in post#3 deze regel bijgevoegd :

Sheets("Archief beveiligers").Cells(Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Row, 5).Value = Now

En het functioneert.

 

[VenA]

@tkint,

Volgens mij kom je dan een regel te laag uit uit.

 

[Bas1980]

@tkint,

Volgens mij kom je dan een regel te laag uit uit.

In mijn bestand krijg ik dan:

 .Copy Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Offset(1)
Sheets("Archief beveiligers").Cells(Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Row, 5).Value = Now

Volgens mij komt de datum dan op een regel te laag idd.

 

[tkint]

@Bas1980

In eerste instantie wel omdat deze regel in de "With - End With" stond .Heb daarnet nog de routine uitgeprobeerd en de datum komt op de juiste regel.
Dus de code plaatsen net achter de End With!
@VenA
Nog even dit : jouw code voor het verwijderen is korter en sneller. Voor een modale VBA-gebruiker (zoals ik) iets te moeilijk vanwege de syntax. Jij hebt duidelijk het gestructureerd programmeren in de vingers!

 

[VenA]

@tkint,
Wat is er moeilijk aan de syntax? En als je wil programmeren dan lijkt het mij logisch dat dit gestructureerd gebeurt

Bij het kopiëren/verplaatsen van 1 rij merk je volgens mij het verschil in snelheid niet. Alleen zou ik het dan zo oplossen

Sheets("Archief beveiligers").Cells(Rows.Count, [COLOR="#FF0000"]5[/COLOR]).End(xlUp), 5).Value = Now

 

[HSV]

Er staat iets dubbelzinnigs in de code van @VenA.

Ik zou het zo oplossen.

 Sheets("Archief beveiligers").Cells(Rows.Count, 5).End(xlUp).Value = Now

Of:

 Sheets("Archief beveiligers").Cells(Rows.Count, 1).End(xlUp).Offset(, 4) = Now

 

[VenA]

@HSV, was blijkbaar een onoplettende copy paste uit #10 of #12

 

[Bas1980]

Na With en End With werkt perfect!

Dank daarvoor. Nu kan ik verder. Jullie zullen mij hier denk ik wel vaker horen aangezien dit het begin is van een zeer grote database cq programma (hoop het niet natuurlijk )