vba code aanpassen voor copieren van gegevens

[Marthy Mc Fly]

Ruim een jaar lang hebben we gebruik kunnen maken van dit bestand. Alleen de afgelopen 2 maanden waren er problemen.
Namelijk de weekend shift werd opgesplitst in twee. Het normale weekend werd een dubbele weekend shift.
Hierdoor konden zij hun gegevens niet meer wegschrijven omdat er maar één kolom voorzien was voor weekend dienst
in de tabbladen die de maanden voorstelden. Met zicht op het nieuwe jaar zoek ik naar een oplossing voor dit probleem.
Ik moet dus het weekend gaan voorzien van twee kolommen. Met name de dag en nacht shift. Alleen zit ik vast met
de vba code die schuil gaat achter de knop transfer op het hoofdblad genaamd Opvolgblad productie.
Vba is voor mij als chinees. Vandaar een oproep naar de experts of de bouwer van deze code.

Hier onder vindt je een voorbeeld van het bestand:
Bekijk bijlage 200893
Dit is het nieuwe bestand:
Bekijk bijlage 200891

Het gaat dus om deze code

Sub Transfer()

Dim iRij As Integer
Dim iKolom As Integer
Dim dDatum As Date
Dim sShift As String
Dim sh As Worksheet
   On Error GoTo Transfer_Error

Application.ScreenUpdating = False
dDatum = Cells(4, 2)
sShift = Cells(4, 5)
'controleer of er een datum en een dienst is ingevuld.
    If sShift = "" Or dDatum = 0 Then
        MsgBox "Vul datum en/of dienst in"
            Exit Sub
    End If
Set sh = Worksheets(UCase(Strings.Format(dDatum, "mmm")))
'controleer weekdag.
    If Weekday(dDatum, 2) > 5 Then
    'weekenddag? maak er dan een weekenddienst van
            iKolom = WorksheetFunction.Match(Cells(4, 5), Range("dienst"), 0) * 5
            
        Else
    'weekdag stel dan de kolom in op de juiste dienst.
            iKolom = WorksheetFunction.Match(Cells(4, 5), Range("dienst"), 0) * 3
    End If
'zoek de datum op en stel de rij in
iRij = WorksheetFunction.Match(Cells(4, 2), sh.Range("A5:A436"), 0) + 4
'kopieer de waardes naar de juiste plaats
    Range("A9:A20").Copy
        sh.Cells(iRij, iKolom).PasteSpecial xlValues
    Range("C9:C20").Copy
        sh.Cells(iRij, iKolom + 1).PasteSpecial xlValues
'selecteer de datum cel(en haal de kopieer kringels weg)
 With Application
    If .CutCopyMode Then .CutCopyMode = False
 End With
    Cells(4, 2).Select
    Call MsgBox("Gegevens zijn overgeschreven")

     
   On Error GoTo 0
   Exit Sub
'foutafhandeling
Transfer_Error:
'als het blad niet bestaat
If Err.Number = 9 Then
        Call MsgBox("Voor de betreffende maand is geen werkblad aanwezig" _
                & vbCrLf & "Voeg dit toe en voer de routine opnieuw uit." _
                , vbCritical, "Werkblad ontbreekt")
'datum niet aanwezig
    ElseIf Err.Number = 1004 Then
        Call MsgBox("De ingevoerde datum is niet gevonden." _
                    & vbCrLf & "Controleer of deze bestaat en voer de routine opnieuw uit." _
                    , vbCritical, "Onjuiste datum")
    Else
'alle andere fouten
        Call MsgBox("Er is een onbekende fout opgetreden." _
                & vbCrLf & vbCrLf & "Foutnummer: " & Err.Number _
                & vbCrLf & "Beschrijving: " & Err.Description _
                , vbCritical, "onbekende fout")
End If
    
    
End Sub

Waarin het volgens mij vooral ligt aan het volgende gedeelte

'controleer weekdag.
    If Weekday(dDatum, 2) > 5 Then
    'weekenddag? maak er dan een weekenddienst van
            iKolom = WorksheetFunction.Match(Cells(4, 5), Range("dienst"), 0) * 5
            
        Else
    'weekdag stel dan de kolom in op de juiste dienst.
            iKolom = WorksheetFunction.Match(Cells(4, 5), Range("dienst"), 0) * 3
    End If

 

[WHER]

Probeer deze eens:

 

[Marthy Mc Fly]

Deze oplossing werkt. Hiervoor met oprechte dank.