Macro maken voor gegevens van een andere tab blad te kopieren op een 2 de tab blad

[davylenders123]

Ben op zoek naar een macro die het volgende kan.

Hij zou gegevens van het tabblad uren moeten kopieren naar het tabblad totaal.
In het tab blad uren daar moet kolom A,B en F gekopieerd worden naar het tabblad totaal.

De lege cellen mogen niet mee gekopieerd worden.

Op tab blad uren staan de namen gegroepeerd per ploeg en staan er op alfabetische volgorden.Dit moet zo blijven.

Op tab blad totaal zouden de namen gewoon op alfabeth moeten komen zonder te kijken naar de ploegen.

Het tabblad totaal is ingedeeld in 2 keer 3 kolomen.
De namen moeten daar gewoon aansluiten in komen te staan.
Van A,B en c 2 tem 51 komen eerst de namen te staan en als die rij vol is gewoon verder gaan van E,F en G 2 tem 51.

Bekijk bijlage vb bestand.xlsx

 

[HSV]

In moduleblad 'uren'.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Variant
   Sheets("totaal").Range("A2:C" & Cells(Rows.Count, 3).End(xlUp).Row).ClearContents
     For Each c In Sheets("uren").Range("F4:F150")
      If IsNumeric(c) Then
        With Sheets("totaal").Cells(Rows.Count, 3).End(xlUp)
            .Offset(1) = c
            .Offset(1, -2).Resize(, 2).Value = c.Offset(, -5).Resize(, 2).Value
          End With
        End If
     Next c
 End Sub

en in moduleblad 'totaal'.

Private Sub Worksheet_Activate()
Range("A2:C" & Cells(Rows.Count, 3).End(xlUp).Row).Sort [B1]
End Sub

 

[Warme bakkertje]

Private Sub Worksheet_Activate()
    Range("A2:C" & Cells(Rows.Count, 3).End(xlUp).Row).Sort [B1]
    If [A52] <> "" Then
        Range("A52:C" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
        Cells(2, 5).PasteSpecial xlPasteValues
        Range("A52:C" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End If
    Application.CutCopyMode = False
End Sub

Met bovenstaande wordt na regel 51 en na sorteren een nieuwe kolom begonnen

 

[Warme bakkertje]

Ik veronderstel dat onderstaande dezelfde is :evil:
http://www.worksheet.nl/forumexcel/vragen/67660-gegevens-van-ander-tab-blad-ophalen.html#post566263

 

[davylenders123]

Harry en Rudi,

1000 maal bedankt jullie hebben we al geweldig verder geholpen.:thumb::thumb:

Harry aan u bestandje heb ik nog wel even de code van Rudi moeten toevoegen want anders maakte hij inderdaad geen 2 de kolom maar ging gewoon verder in de eesrte.

Heb nog een paar kleine probleempje.
Het tab blad totaal zou ik graag beveiligen met een paswoord , maar dat gaat niet als ik daar een paswoord opzet krijg in onmiddelijk een foutmelding (code 1004).

Wat moet er hier nog worden aangepast voor dit op te lossen.

En als er bij eind uur geen uur is ingevuld zou de naam in het tab blad totaal ook moeten verwijderd worden.
Is dit moggelijk ?

 

[davylenders123]

Ik veronderstel dat onderstaande dezelfde is :evil:
http://www.worksheet.nl/forumexcel/vragen/67660-gegevens-van-ander-tab-blad-ophalen.html#post566263

Rudi,

Ja dit gaat inderdaad over het zelfde.

Heb dit al eens op een andere manir gepost hier en er was geen oplossing gevonden, daarom had ik het eens ergens anders geplaast ook.

 

[davylenders123]

Ben juist nog op een probleemje gelopen.

Ik zou ook de volgende zaken moeten kunnen invullen zodat deze in de plaast komen te staan van kolom totaal en kolom min pauze in het tab blad uren en dat dit zo wordt overgenomen in het tabblad totaal.

Ziek
ON
Bv
verlof
AO

Dus deze afkortingen kunnen ingeven als ze niet komen werken zijn en dit plaasten in de plaats waar normaal het totaal aantal gewerkt uren staat.

Hoe kan ik dit het beste oplossen.
Door gewoon een extra kolom toe te voegen , zo een als kolom a met een keuzen lijst en al de codes aanpassen, of is hier een beter en makkelijker manier voor.

 

[HSV]

En als er bij eind uur geen uur is ingevuld zou de naam in het tab blad totaal ook moeten verwijderd worden.
Is dit moggelijk ?

Verander de code in.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Variant
   Sheets("totaal").Range("A2:C" & Cells(Rows.Count, 3).End(xlUp).Row).ClearContents
     For Each c In Sheets("uren").Range("D4:D150")
      If c > 0 Then
        With Sheets("totaal").Cells(Rows.Count, 3).End(xlUp)
            .Offset(1) = c.Offset(, 2)
            .Offset(1, -2).Resize(, 2).Value = c.Offset(, -3).Resize(, 2).Value
          End With
        End If
     Next c
 End Sub

Misschien past dit beter.

 

[Warme bakkertje]

Plaats anders eens terug een voorbeeldbestandje met hoe je het nu zou willen op Tab Uren. Zet op tab Totaal ook enkele regels hoe het uiteindelijke resultaat er moet uitzien. Dit verkleint de kans op over en weer geschrijf en kunnen wij je gerichter helpen.

 

[davylenders123]

Heb een nieuw vb bestandje gemaakt zoals je gevraagd hebt.

Bekijk bijlage voorbeeld 3.rar


Heb zoveel namen aangemaakt zodat je de 2 de kolom in tabblad totaal ook nodig hebt.

1.Ik heb een kolom toegevoegd (c) waar dat de afwezigheids reden kunnen worden gekozen uit een keuzen menu.
Als de persoon komt werken dan moeten gewoon de uren worden ingevuld zoals het al was en blijft de cel in kolom c leeg.
Is de persoon afwezig om de een af andere reden dan moet er een reden gekozen worden in kolom cen blijven de cellen begin en eind uur leeg.
De afwezigheids reden zou mee overgenomen moeten worden in tabblad totaal zodat dar bij uren de afwezigheids reden komt te staan.

Door deze rij toe te voegen werkt de code in tabblad totaal niet meer juist.


2.Het tabblad totaal zou met een wachtwoord moeten kunnen beveiligd worden zodat ze hier geen aanpassingen kunnen aanbrengen.
Zoals ook tabblad uren waar een deel cellen zijn beveiligd.
Het bestand gaat door meerder personen gebruikt worden daar deze beveiliging daar.


3.Harry denk dat in de code die je het laste geplaats hebt nog een foutje zit.
5Naam niet overnemen als er niks bij kolom eind staat)
Hij doet alles correct in de kolom a,b en c in tabblad totaal.
Maar in kolom e,f en g verwijdert hij niet altijd de de naam of hij verwijderd de naam en plaatst een bestaande naam opnieuw.

Hoop dat jullie er zo aanuit kunnen en mij verder kunnen helpen.
Alvast bedankt voor jullie hulp al tot hier toe top :thumb:.

 

[HSV]

Er ging zeker iets mis; nieuwe poging.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Variant
   Sheets("totaal").Range("A2:G" & [COLOR="red"]Sheets("totaal").[/COLOR]Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents
     For Each c In Sheets("uren").[COLOR="red"]Range("E4:E150")[/COLOR]      If c > 0 Then
        With Sheets("totaal").Cells(Rows.Count, 3).End(xlUp)
            .Offset(1) = c.Offset(, 2)
            .Offset(1, -2).Resize(, 2).Value = c.Offset(, [COLOR="red"]-4[/COLOR]).Resize(, 2).Value
          End With
        End If
     Next c
 End Sub

 

[davylenders123]

Er ging zeker iets mis; nieuwe poging.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Variant
   Sheets("totaal").Range("A2:G" & [COLOR="red"]Sheets("totaal").[/COLOR]Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents
     For Each c In Sheets("uren").[COLOR="red"]Range("E4:E150")[/COLOR]      If c > 0 Then
        With Sheets("totaal").Cells(Rows.Count, 3).End(xlUp)
            .Offset(1) = c.Offset(, 2)
            .Offset(1, -2).Resize(, 2).Value = c.Offset(, [COLOR="red"]-4[/COLOR]).Resize(, 2).Value
          End With
        End If
     Next c
 End Sub

Krijg nu een foutcode als ik op tabblad uren een aanpassing doe.
"compileerfout" syntaxisfout"

Ik moest de code toch vervangen in tabblad uren he ?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Variant
   Sheets("totaal").Range("A2:G" & Sheets("totaal").Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents
     For Each c In Sheets("uren").Range("E4:E150")      If c > 0 Then
        With Sheets("totaal").Cells(Rows.Count, 3).End(xlUp)
            .Offset(1) = c.Offset(, 2)
            .Offset(1, -2).Resize(, 2).Value = c.Offset(, -4).Resize(, 2).Value
          End With
        End If
     Next c
 End Sub

 

[davylenders123]

Heb nog iets belangtijks vergeten te vermelden het moet kunnen draaien op excel 2003.

Ik heb de vb bestanden verkeerd opgeslagen.
Sorry

 

[HSV]

Werkt perfect bij mij.
Als ik de uren invul of weghaal bij 'eind uur' draait blad 'totaal' als een tierelier.

Op welke regel krijg je de melding.

 

[davylenders123]

Werkt perfect bij mij.
Als ik de uren invul of weghaal bij 'eind uur' draait blad 'totaal' als een tierelier.

Op welke regel krijg je de melding.

Inderdaad op u bestandje werkt het perfect nu.:thumb:

Zal dan wel iets fout gedaan hebbenn bij mij.

Rudi dan kan je beter het laaste bestandje van harry gebruiken als voorbeeld bestandje.

 

[davylenders123]

Werkt perfect bij mij.
Als ik de uren invul of weghaal bij 'eind uur' draait blad 'totaal' als een tierelier.

Op welke regel krijg je de melding.

Zie het verschil al een fout in de code .
Heb het zo

For Each c In Sheets("uren").Range("E4:E150")      If c > 0 Then

gekopieerd.
En het moet zijn

For Each c In Sheets("uren").Range("E4:E150")     
 If c > 0 Then

En dan werkt het bij mij zelf ook normaal.

Dus nr 3 is al opgelost .

Bedankt hiervoor al.

 

[HSV]

Dus nr 3 is al opgelost .
Bedankt hiervoor al.

En met nr. 1 kunnen we weer van voor af aan beginnen.
Wel een beetje jammer Davy.

 

[davylenders123]

En met nr. 1 kunnen we weer van voor af aan beginnen.
Wel een beetje jammer Davy.

Ik weet het , stom van mij om dit over het hoofd te zien bij het begin sorry daarvoor

 

[Warme bakkertje]

Met dank aan Harry voor al het voorbereidende werk :thumb:
Deze in Uren

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Variant
    Application.ScreenUpdating = False
    With Sheets("totaal")
        .Unprotect "Davy"
        .Range("A2:G" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
        For Each c In Sheets("uren").Range("B4:B150")
            If c <> "" Then
                .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 2) = Cells(c.Row, 1).Resize(, 2).Value
                .Cells(Rows.Count, 3).End(xlUp).Offset(1) = IIf(c.Offset(, 1) <> "", c.Offset(, 1).Value, c.Offset(, 4).Value)
            End If
        Next c
     .Protect "Davy"
     End With
     Application.ScreenUpdating = True
End Sub

en deze in totaal

Private Sub Worksheet_Activate()
    ActiveSheet.Unprotect "Davy"
    Range("A2:C" & Cells(Rows.Count, 3).End(xlUp).Row).Sort [B1]
    If [A52] <> "" Then
        Range("A52:C" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
        Cells(2, 5).PasteSpecial xlPasteValues
        Range("A52:C" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End If
    Application.CutCopyMode = False
    ActiveSheet.Protect "Davy"
End Sub

Wijzig in beide macro's wel naar het juiste paswoord.

 

[davylenders123]

Met dank aan Harry voor al het voorbereidende werk :thumb:
Deze in Uren

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Variant
    Application.ScreenUpdating = False
    With Sheets("totaal")
        .Unprotect "Davy"
        .Range("A2:G" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
        For Each c In Sheets("uren").Range("B4:B150")
            If c <> "" Then
                .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 2) = Cells(c.Row, 1).Resize(, 2).Value
                .Cells(Rows.Count, 3).End(xlUp).Offset(1) = IIf(c.Offset(, 1) <> "", c.Offset(, 1).Value, c.Offset(, 4).Value)
            End If
        Next c
     .Protect "Davy"
     End With
     Application.ScreenUpdating = True
End Sub

en deze in totaal

Private Sub Worksheet_Activate()
    ActiveSheet.Unprotect "Davy"
    Range("A2:C" & Cells(Rows.Count, 3).End(xlUp).Row).Sort [B1]
    If [A52] <> "" Then
        Range("A52:C" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
        Cells(2, 5).PasteSpecial xlPasteValues
        Range("A52:C" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End If
    Application.CutCopyMode = False
    ActiveSheet.Protect "Davy"
End Sub

Wijzig in beide macro's wel naar het juiste paswoord.

Harry en Rudi,

Jullie verdienen een stambeeld echt top wat jullie doen.

Rudi er is echter nog een klein foutje ergens in u codes maar kan niet vinden wat.

In het laatste bestand van Harry als ik daar in het tabblad uren de cellen bij een bepaalde naam leeg laat dan staat er niks bij het tabblad totaal.

1.Doe ik daar de naam weg dan is de naam ook weg op tabblad totaal.
2.Doe ik daar het begin uur weg dan is het uur vakje in tabblad totaal leeg maar staat de naam er nog.
3.Doe ik daar het eind uur weg dan is de naam ook weg op tabblad totaal.

Als ik u code gebruik dan blijft het staan in tabblad totaal.

1.Doe ik in tabblad uren de naam weg dan is de naam ook weg op tabblad totaal.

2. Doe ik in tabblad uren afwezigheid weg dan veranderd in tabblad totaal de afwezigheids reden gewoon in uren.

3.Doe ik in tabblad uren het begin uur weg dan blijft het uur in tabblad totaal staan.

4.Doe ik in tabblad uren het eind uur weg dan veranderd het uur in een ziekte periode of blijft het uur in tabblad totaal gewoon staan.

Het zou eigenlijk mogen worden.
1.Doe ik in tabblad uren de naam weg dan is de naam ook weg op tabblad totaal.

2.Doe ik in tabblad uren de afwezigheid weg dan is het uur vakje in tabblad totaal leeg maar staat de naam er nog.

3.Doe ik in tabblad uren het begin uur weg dan is het uur vakje in tabblad totaal leeg maar staat de naam er nog.

4.Doe ik in tabblad uren het eind uur weg dan is het uur vakje in tabblad totaal leeg maar staat de naam er nog.

Dus eigenlijk als ik in tabblad uren de naam verwijder dan moet hij in tabblad totaal ook weg zijn.
Als al de andere vakjes leeg zijn of er 1 niet van is ingegeven dan moet de naam in tabblad totaal blijven staan maar het uur vakje moet leeg blijven.