Regels uit tabel laten verplaatsen naar ander tabblad

Status
Niet open voor verdere reacties.
G

Gerjan87

Gebruiker
Lid geworden
26 dec 2016
Berichten
8
Dag Iedereen,

Bijgaand een bestand wat ik heb gemaakt. Voor het voorbeeld heb ik alle gegevens en enkele macro's verwijderd. In principe werkt alles goed maar heb 1 kleine probleem.

Door middel van enkele knoppen kun je regels uit de tabel verplaatsen naar een ander tabblad . Eigenlijk wordt de regel gekopieerd naar een andere tabblad en wordt de oude regel verwijderd. Dit kun je doen door een willekeurige cel in de regel die verplaatst moet worden te selecteren, en dan op de knop "gereed melden" en "verwijderen" te drukken.

Zodra er geen filters aan staan in de tabel werkt dit prima. Echter zodra er een filter aan staat van de tabel (dus niet de hele tabel zichtbaar is) werkt het net niet. de te verplaatsen regel wordt wel gekopieerd naar het andere tabblad maar de oude regel wordt niet verwijderd...? Op die manier staat de zelfde regel in twee tabbladen wat niet mag.
Alle wordt gestuurd middels VBA en heb al aardig wat geprobeerd om dit probleem te verhelpen. De oude regel moet dus verwijdert worden ongeacht of er filters aanstaan in de tabel. Hopelijk weten jullie een mogelijk oplossing?

Alvast bedankt!
 

Bijlagen

  • Voorbeeld Forum.xlsm
    320,9 KB · Weergaven: 44
Laatst bewerkt:
als je in de macro verwijderen copy veranderd in cut?
 
Helaas werkt dat niet. Was het maar zo makkelijk:)
Toch bedankt voor het meedenken.
 
Code: 
'naar colom c t/m R kopieeren
    Range("c" & r, "r" & r).Copy Destination:=Sheets("Afgerond").Range("C" & iRow, "q" & iRow)
    Range("c" & r, "r" & r).[COLOR="#FF0000"]ListObject.ListRows(r - 8).[/COLOR]Delete
en als je nu het rode weg haalt?
of moet de regel ook meteen naar verwijderd als die uit actueel gaat?
 
Grappig, als je dat stuk code weg haalt doet de marco het inderdaad nog steeds.
Helaas nog steeds de zelfde fout echter. Zodra er een filter aan staat wordt de regel niet verwijderen. Helaas komt er dan nu ook een foutmelding.
 
Misschien eerst eens verdiepen in de werking van tabellen in VBA?:d

In de module van Thisworkbook lijkt mij dit voldoende
Code: 
Private Sub Workbook_Open()
  Sheets("Actueel").ListObjects(1).AutoFilter.ShowAllData
End Sub

Voor het verplaatsen en verwijderen kan je het beste ook binnen de tabel blijven. Je krijgt dan zoiets
Code: 
Sub VenA()
  With ActiveSheet.ListObjects(1)
    If Not Intersect(ActiveCell, .DataBodyRange) Is Nothing Then
      Sheets("Verwijderd").ListObjects(1).ListRows.Add.Range.Resize(, .ListColumns.Count) = .Range.Rows(ActiveCell.Row + 1 - .HeaderRowRange.Row).Resize(, .ListColumns.Count).Value
      Application.DisplayAlerts = False
      .Range.Rows(ActiveCell.Row + 1 - .HeaderRowRange.Row).Delete
      Application.DisplayAlerts = True
    End If
  End With
End Sub

In een gefilterde tabel krijg je een melding daarom deze middels DisplayAlerts uitgezet.
 
Misschien eerst eens verdiepen in Listrows. ;)

Vreemde benadering om bij de activecell.row +1 bij te tellen.
Zonder displayalerts doordat er zo geen melding komt.

Code: 
Sub hsv()
  With ActiveSheet.ListObjects(1)
    If Not Intersect(ActiveCell, .DataBodyRange) Is Nothing Then
      Sheets("Verwijderd").ListObjects(1).ListRows.Add.Range.Resize(, .ListColumns.Count) = .ListRows(ActiveCell.Row - .HeaderRowRange.Row).Range.Value
      .ListRows(ActiveCell.Row - .HeaderRowRange.Row).Delete
    End If
  End With
End Sub

Werkt niet in een gefilterd tabel overigens.

Dan moet het wel met displayalerts = false
Code: 
Sub hsv()
  With ActiveSheet.ListObjects(1)
    If Not Intersect(ActiveCell, .DataBodyRange) Is Nothing Then
      Sheets("Verwijderd").ListObjects(1).ListRows.Add.Range.Resize(, .ListColumns.Count) = .ListRows(ActiveCell.Row - .HeaderRowRange.Row).Range.Value
      Application.DisplayAlerts = False
      .ListRows(ActiveCell.Row - .HeaderRowRange.Row).Range.Delete
    End If
  End With
End Sub
 
Laatst bewerkt:
Omdat de tabellen even groot zijn kan het rode gedeelte er ook wel uit.

Code: 
Sub hsv()
  With ActiveSheet.ListObjects(1)
    If Not Intersect(ActiveCell, .DataBodyRange) Is Nothing Then
      Sheets("Verwijderd").ListObjects(1).ListRows.Add.Range[COLOR=#ff0000].Resize(, .ListColumns.Count)[/COLOR] = .ListRows(ActiveCell.Row - .HeaderRowRange.Row).Range.Value
      Application.DisplayAlerts = False
      .ListRows(ActiveCell.Row - .HeaderRowRange.Row).Range.Delete
    End If
  End With
End Sub

Of nog iets korter.
Code: 
Sub hsv()
  With ActiveSheet.ListObjects(1)
    If Not Intersect(ActiveCell, .DataBodyRange) Is Nothing Then
      Sheets("Verwijderd").ListObjects(1).ListRows.Add.Range = .ListRows(ActiveCell.Row - [COLOR="#FF0000"].Range[/COLOR].Row).Range.Value
      Application.DisplayAlerts = False 'voor gefilterde rijen.
      .ListRows(ActiveCell.Row - [COLOR="#FF0000"].Range[/COLOR].Row).Range.Delete
    End If
  End With
End Sub
 
Laatst bewerkt:
VenA en HSV, bedankt!
Ik ben er ondertussen helemaal uit dankzij jullie oplossing
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan