Rijen selecteren met selectievak en met knop en macro verplaatsen naar ander werkblad

[gemuseman]

Wie kan mij helpen? Ben al dagen aan het proberen. Dit is mijn eerste experiment met macro’s in Excel. Waarschijnlijk is er een simpele oplossing maar die zie ik niet. (Ik ben gebonden aan Excel 2003)

In de bijlage een overzicht van mensen die geplaatst worden in een verpleeghuis (vph) of naar de thuiszorg (thuisz) .
Tabblad 1: de mensen die op de lijst staan voor thuiszorg. Zodra ze uitgeplaatst zijn mag de persoon naar de jaarlijst (tabblad 2) en worden de gegevens statisch.
Tabblad 3: de mensen die op de lijst staan voor een vph. Idem worden de gegevens verplaatst naar tabblad 4 als de mensen uitgeplaatst zijn.

Ik wil een eenvoudige manier om de mensen te verplaatsen van blad 1 naar blad 2, (van blad 3 naar blad 4) en een enkele persoon van blad 3 naar blad 1.
Daarom heb ik een aantal knoppen gemaakt.
Problemen waar ik tegen aanloop:
- Als je niet de hele rij selecteert maar een enkele cel in de rij dan werkt de knop niet goed. Gegevens komen dan verkeerd in de jaarlijst te staan.
- Als je de auto-filter gebruikt en meerdere rijen tegelijk selecteert dan komen de gegevens hopeloos doorelkaar.
- Als je per ongeluk op een knop drukt dan is de rij weg en je weet niet welke. De ongedaan-toets werkt niet na een macro, dus die gegevens ben je kwijt.

De oplossing die ik bedacht heb: maak voor iedere rij een selectievakje. Zie het voorbeeld in tabblad “thuiszorg”. Als je het vakje aanklikt dan kleurt de rij grijs. Dat is een extra check zodat je niet per ongeluk het verkeerde verwijderd. Als je vervolgens op de knop klikt dan wordt de macro uitgevoerd bij rijen die aangevinkt zijn.
Het volgende gaat mis:
- De ingeschakelde selectievakjes aan de macro koppelen. Zodat ik de rijen die ik met de knop wil verplaatsen of verwijderen eerst kan aanvinken. (je moet ook meerder rijen kunnen selecteren en ook als filters ingeschakeld zijn)
- Het selectievakje is niet aan de rij gekoppeld. Als je een rij verwijderd blijft het selectievakje staan. Er komen dan 2 selectievakjes bovenelkaar te staan.
- Voor iedere rij moet je het selectievakje apart koppelen. VB C34 aan D34 enz. Dit kost veel tijd omdat het op 2 bladen moet en totaal op ongeveer 250 -300 rijen.
- De voorwaardelijke opmaak waardoor de rij grijs kleurt moet ik rij voor rij instellen.

’t Zijn veel vragen. Sorry. Ik hoop dat iemand mij kan helpen.

Let op: het bestandje van 344,5 KB is het juiste bestand. Het andere is verkeerd door mij gepost.

 

[gemuseman]

Verkeerde bijlage

Bekijk bijlage Kopie van trsflijst forum.xls Sorry, ik heb de verkeerde bijlage geplaatst. Maar het lukt mij niet dit bestand te verwijderen en het juiste te plaatsten. Hierbij het juiste bestand.

 

[gemuseman]

Verplaaten met waarde "x" ipv selectievakje

Bekijk bijlage trsflijst_forum1.xlsIn plaats van selectievakjes heb ik gekozen voor de waarde "x" in kolom a. (zie blad 1 en 2 in bijlage)
Als je op de knop "Naar Jaarlijst" drukt, dan worden de rijen die in kolom a met een x gemarkeerd zijn verplaatst naar blad 2.
Onderstaande code heb ik gevonden maar er zit een foutje in want bij het plakken op blad 2 schrijft hij de onderste regel van blad 2 over....

Alvast bedankt voor de hulp.

Sub rowcopy()
Dim rij As Long
Dim n As Long
Dim src As Worksheet
Dim trg As Worksheet
Set src = Sheets("Blad1")
Set trg = Sheets("Blad2")

Sheets("Blad1").Unprotect
Sheets("Blad1").Unprotect
Application.ScreenUpdating = False
rij = trg.[A65536].End(xlUp).Row
For n = 1 To Blad1.[A65536].End(xlUp).Row
If Cells(n, "a").Value = "x" Then
Range(Cells(n, "b"), Cells(n, "s")).Copy
trg.Cells(rij, "A").PasteSpecial
Range(Cells(n, "A"), Cells(n, "K")).EntireRow.ClearContents
rij = rij + 1
End If
Next
    Sheets("Blad1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
        AllowFiltering:=True, AllowUsingPivotTables:=True
    Sheets("Blad2").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
        AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub

 

[Warme bakkertje]

Sub kopieer()
  Application.ScreenUpdating = False
  With Sheets("Blad1")
        .Unprotect
        .AutoFilterMode = False
        .Range("A33").AutoFilter 1, "x"
        If .AutoFilter.Range.Columns(1).SpecialCells(xlVisible).Count > 1 Then
            .AutoFilter.Range.Offset(1, 1).SpecialCells(xlVisible).Copy
            Sheets("Blad2").[A65536].End(xlUp).Offset(1).PasteSpecial xlValues
        End If
        .AutoFilterMode = False
        .Protect
  End With
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
End Sub

 

[gemuseman]

Rudi,

Bedankt voor je antwoord.
Ik heb je code gekopieerd naar het werkblad maar hij doet niets.
Zelf ben ik aan het puzzelen geweest en met deze code lukt het wel.
Maar wellicht is jou manier beter? Het excel-sheet moet zo stabiel mogelijk zijn want er gaan semi-digibeten mee werken.

Ondanks dat het nu gelukt lijkt wil ik de topic nog even open laten staan want kopieren van het 3e naar het 4e blad heb ik nog niet voorelkaar. Ik ga daar nog even op puzzelen. Op het 3e blad staan formules die bij het kopieren moeten blijven staan.
Op het 4e blad kunnen de gegevens statisch worden. Daar wil ik dus alleen de waarden plakken.

Ben hier al 1,5 week mee bezig en heb eigenlijk pas maandag weer tijd. Maar probeer wel af en toe te kijken.

Bekijk bijlage trsflijst 17-1 (1).xls
( op de plaats van de Smiley moet staan dubbele punt p )

Gerard.

Sub thuis_jaar()
Dim rij As Long
Dim n As Long
Dim src As Worksheet
Dim trg As Worksheet
Set src = Sheets("thuisz")
Set trg = Sheets("jaarl thuisz")

Sheets("thuisz").Unprotect
Sheets("jaarl thuisz").Unprotect
Application.ScreenUpdating = False
rij = trg.[A65536].End(xlUp).Row
For n = 1 To Blad1.[A65536].End(xlUp).Row
If Cells(n, "a").Value = "x" Then
Range(Cells(n, "b"), Cells(n, "s")).Copy
trg.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
Range(Cells(n, "A"), Cells(n, "K")).EntireRow.ClearContents
rij = rij + 1
End If
Next
Range("A34:P6484").Sort Key1:=Range("B34"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Sheets("thuisz").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
        AllowFiltering:=True, AllowUsingPivotTables:=True
    Sheets("jaarl thuisz").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
        AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub

 

[Warme bakkertje]

Sub kopieer()
  Application.ScreenUpdating = False
  With Sheets("thuisz")
        .Unprotect
        .AutoFilterMode = False
        .Range("A33").AutoFilter 1, "x"
        If .AutoFilter.Range.Columns(1).SpecialCells(xlVisible).Count > 0 Then
            .AutoFilter.Range.Offset(1, 1).SpecialCells(xlVisible).Copy
            Sheets("jaarl thuisz").[A65536].End(xlUp).Offset(1).PasteSpecial xlValues
        End If
        .AutoFilterMode = False
        .Protect
  End With
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
End Sub

 

[gemuseman]

Beste Rudi,

Nogmaals bedankt.

Nu wordt de rij wel gekopieerd aar het 2e blad, maar blijft in het eerste blad staan. Dat is niet de bedoeling.
Als de persoon overgeplaatst is dan mag deze uit de actuele lijst verdwijnen (blad thuisz) en in het archief opgeslagen worden (blad jaarl thuisz)
Mijn bedoeling is om de macro aan een knop te koppelen. Als ik op de knop druk terwijl er geen x in de eerste kolom staat, dan verdwijnen al mijn gegevens van het werkblad. De eerst zichtbare rij is dan rij 38.
En de auto-fliter functie wordt na het uitvoeren van de macro uitgeschakeld.Bekijk bijlage trsflijst 17-1 (1) (3).xls

Gerard.

 

[Warme bakkertje]

Sub kopieer()
  Application.ScreenUpdating = False
  With Sheets("thuisz")
        If WorksheetFunction.CountA(.Range("A34:A" & .Cells(Rows.Count, 2).End(xlUp).Row)) = 0 Then Exit Sub
        .Unprotect
        .AutoFilterMode = False
        .Range("A33").AutoFilter 1, "x"
        .AutoFilter.Range.Offset(1, 1).SpecialCells(xlVisible).Copy
        Sheets("jaarl thuisz").[A65536].End(xlUp).Offset(1).PasteSpecial xlValues
        .AutoFilter.Range.Offset(1).SpecialCells(xlVisible).ClearContents
        .AutoFilterMode = False
        .Range("A34:P6484").Sort .Range("B34"), xlAscending
        .Protect
  End With
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
End Sub

 

[gemuseman]

Beste Rudi,

Bedankt voor de moeite. Super. Nu werkt het wel goed.
Maandag wil ik verder gaan met het 3e werkblad.

Gerard

 

[gemuseman]

Goedemiddag,

Het is me gelukt om op het werkblad VPH een knop te maken "naar Jaarlijst". De rij wordt dan gekopieerd van tabblad VPH naar tabblad "jaarlijst VPH". Daarvoor heb ik jou code gebruikt Rudi.
Maar, de formules in kolommen o, p en v zijn na het verwijderen op tabblad VPH verdwenen. Die moeten daar blijven staan om de volgende patient te kunnen invoeren. De hele rij verwijderen vind ik geen goede optie want anders raakt over een tijdje mijn blad met gegevens "op". Ik wil de fomules namelijk niet helemaal tot de onderste rij doorvoeren omdat dan de auto-filterfunctie uiterst traag gaat werken.

Verder:
Op tabblad VPH is een knop "naar thuiszorg". Soms moet de persoon niet naar een verpleeghuis maar krijgt thuiszorg.
Van die persoon moeten dan de gegevens in de kolommen C t/m h van het tabblad VPH, verhuizen naar het tabblad thuiszorg de kolommen B t/m G.
De resterende gegevens van die patient op tabblad VPH moeten gedelete worden.
Ik ben hiermee aan het puzzelen maar stop er nu even me i.v.m. de beschikbare tijd.

Alvast hartelijk dank voor de moeite.

PS: in de bijlage heb ik de bladen jaarl thuisz en jaarlijst VPH even verwijderd omdat het bestand te groot was om te uploaden.

Bekijk bijlage trsflijst 17-1 versie 3.xls

 

[gemuseman]

Wie wil mij aub helpen. Ik kom er niet uit en volgens mij is het iets simpels.

Ik wil gegevens verplaatsen van werkblad VPH naar werkbld Jaarlijst VPH. Als ik in de eerste kolom op blad VPH een x plaats, en op de knop Jaarlijst druk dan worden de gegevens verplaatst.
Maar het gaat nog niet helemaal goed.


* Formules in de kolommen P, Q en V op werkblad VPH moeten intact blijven.( blauw gemarkeerd)
* Op werkblad jaarlijst VPH wil ik geen formules. Alleen de waarden mogen hier geplakt worden.
* Werkblad VPH wil ik uit ongeveer max 500 regels laten bestaan om de auto-filter functie niet te traag te maken. Maar hierdoor kan ik niet eenvoudigweg de gehele rij verwijderen omdat dan na verloop van tijd het einde van het werkblad bereikt wordt.

Je maakt me erg blij als je me wil helpen.


Sub VPH_kopieer()
'
'kopieert van vph naar jaarlijst
'

Application.ScreenUpdating = False
With Sheets("VPH")
If WorksheetFunction.CountA(.Range("A49:A" & .Cells(Rows.Count, 2).End(xlUp).Row)) = 0 Then Exit Sub
.Unprotect
.AutoFilterMode = False
.Range("A48").AutoFilter 1, "x"
.AutoFilter.Range.Offset(1, 1).SpecialCells(xlVisible).Copy
Sheets("jaarlijst VPH").[A65536].End(xlUp).Offset(1).PasteSpecial xlValues
.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).ClearContents
.AutoFilterMode = False
.Range("A49:AA6484").Sort .Range("B49"), xlAscending
.Range("a48:aa3291").AutoFilter Field:=1
.Protect
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub






Bekijk bijlage trsflijst1.xls

 

[gemuseman]

Goedendag,

Het is me gelukt maar het is nogal een monsterlijke code geworden.
Dat kan vast eenvoudiger.
Maar het werkt wel.

Bekijk bijlage trsflijst2.xls


Sub vph_jaar()
Dim rij As Long
Dim n As Long
Dim vph As Worksheet
Dim jrvph As Worksheet
Set vph = Sheets("VPH")
Set jrvph = Sheets("jaarlijst VPH")

Sheets("VPH").Unprotect
Sheets("jaarlijst VPH").Unprotect
Application.ScreenUpdating = False
rij = jrvph.[A65536].End(xlUp).Row
For n = 1 To Blad3.[A65536].End(xlUp).Row
If Cells(n, "a").Value = "x" Then
Range(Cells(n, "b"), Cells(n, "aa")).Copy
jrvph.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range(Cells(n, "A"), Cells(n, "o")).ClearContents
Range(Cells(n, "r"), Cells(n, "u")).ClearContents
Range(Cells(n, "w"), Cells(n, "aa")).ClearContents
rij = rij + 1
End If
Next



vph.Range("a48:AA65534").Select
Selection.Sort Key1:=Range("C49"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal vph.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True


Sheets("jaarlijst VPH").Select
ActiveWindow.SmallScroll Down:=-15
Range("A3:Z3300").Sort Key1:=Range("B3"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
Sheets("jaarlijst VPH").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True


Range("A37").Select
Sheets("VPH").Select
Range("b61").Select


End Sub