VBA code voor kopiëren onderdelen op 1 rij en dat herhalen voor andere rijen

[86Marcos]

Goedemorgen,

Dit is me eerste vraag stuk die ik hier ga zetten. Weet niet of de titel duidelijk is of als ik me vraag duidelijk ga krijgen. Mochten er dus vragen zijn na aanleiding van onderstaand, dan verneem ik deze graag.

Situatie:
We moeten binnenkort uren registratie doen op ons werk. Vraag was of ik dit wilde opstellen.
Had een opstelling gemaakt dat je onder elkaar aangaf welke dag, je voor welk project welke taak had gedaan. Vanaf hoelaat, tot hoelaat en hoeveel uur dat dus was.
Daarbij is de vraag ook om dit inzichtelijk te maken voor iedereen die de registratie invult, dus via macro's had ik een totaal sheet opgesteld.
Dit werkte en nadat ik het liet zien kreeg ik de vraag of ik de invoer sheet anders wilde maken

Ze willen namelijk dat je onder elkaar aangeeft welke taak je doet en dan in dezelfde rij aangeeft hoeveel uur per dag. De dagen staan nu in de kolommen erboven.

Vraag:
Ik zoek een Macro, die het volgende voor me doet:
Tabblad 1 heeft op Rij15 staan welk Project met welke taak.
Tabblad 2 moet hiervan onder elkaar een opstelling maken als met als kolommen:
Project, Taak, Weekdag, Datum, Uur, Gefactureerd, Collega, Afdeling,
Dan als Rij15 op tabblad 1 volbracht is, kijken of Rij16 een waarde heeft, zo ja, deze weer op Tabblad 2 vullen.

Deze Macro, die op die manier vult kan ik niet vinden.

Wat heb ik al:
De aangepaste test sheet is de nieuwe hoe ze het nu vragen. De overige twee is wat ik al had.

Voor dus de originele bestanden was onderstaand de code:

Sub samenvoegen_bestanden_deel2()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("Locatie bestanden")

Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

'change "A2" with cell reference of start point for every files here
'for example "B3:IV" to merge all files start from columns B and rows 3
'If you're files using more than IV column, change it to the latest column
'Also change "A" column on "A65536" to the same column as start point

‘Voer CreateNewSheet macro uit
CreateNewSheet

‘Voer RowCopy macro uit
RowCopy

Sheets("Totaal invoer uren").Select
Range("A2:IV" & Range("A1048576").End(xlUp).Row).Copy

ThisWorkbook.Worksheets(1).Activate

'Do no change the following column. It's not the same column as above
Worksheets("Totaal").Select
Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False
bookList.Close
Next
End Sub


Sub CreateNewSheet()
sheet_name_to_create = "Totaal invoer uren"

For rep = 1 To (Worksheets.Count)
    If LCase(Sheets(rep).Name) = LCase(sheet_name_to_create) Then
MsgBox "This sheet already exists!"
Exit Sub
End If

Next
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(ActiveSheet.Name).Name = sheet_name_to_create

End Sub

Sub RowCopy()
    
Dim RTOTAAL As Integer
Dim RDUMP As Integer

    RTOTAAL = 2
    RDUMP = 1

        TOTAAL = Sheets("TimeLog").Rows.Count  ' Totaal aantal rijen binnen dit werkblad
        LR = Sheets("TimeLog").Range("B" & TOTAAL).End(xlUp).Row  ' Laatste rij van dit gegevensblad

            Worksheets("TimeLog").Activate
            Worksheets("TimeLog").Range("M14").Select
            
    Application.ScreenUpdating = False

For RTOTAAL = LR To 2 Step -1
    
If Worksheets("Timelog").Cells(RTOTAAL, 13).Value = "X" Then
Worksheets("Timelog").Cells(RTOTAAL, 13).EntireRow.Copy
Sheets("Totaal invoer uren").Select

Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues


End If
Next

End Sub

Voor de aangepaste versie heb ik wel een code:

Sub DoorVoerSheetVullen()

‘Deze Macro moet gestart worden als in TimeLog een Cel tussen A15 en A-tot het einde gevuld wordt
‘Onderstaand moet herhaald worden voor elke dag in de week

Range("A2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[13]C"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[13]C"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[10]C"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[11]C[-1]"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=IF(TimeLog!R[13]C[-2]="""","""",TimeLog!R[13]C[-2])"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[13]C[4]"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[13]C[6]"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=TimeLog!R[13]C[6]"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",""X"")"

'Wanneer alle A-cellen in Timelog op bovenstaande manier zijn behandeld moet de Macro stoppen
End Sub

Het is een lange vraag, daar ben ik me bewust van. Hopelijk heeft iemand een idee of tip hoe ik dit kan verwerken.

Met vriendelijke groet,

Marcos

 

[gast0660]

Ik heb uw vbtjes een paar keer bekeken, en uw vraag een paar keer doorgelezen, en eerlijk ik snap er niets van.
Verder zijn uw vbtjes een raadsel. In de ene heb je alleen uren in de andere startijd, eindtijd, break,Wat wil je precies?
Wat moet het resultaat zijn met meerdere collega's?
Ik persoonlijk zou een userform gebruiken.
Dan kan je het blad registratie invullen, opslaan, printen, opslaan als PDF en de ingevulde data worden weggeschreven naar Blad2 de database.
Als je een representatief vbtje post van de gewenste resultaten in het registratieformulier (blad1) en de gewenste resultaten in de database (blad2) (met meerdere collega's,meerdere projecten) dan kan ik eens kijken als ik een voorzetje kan geven.