copy date in vba kan niet met een cel waar een formule in staat ????

[rogersmeets]

vraagje
ik schrijf met onderstaande code de rij getallen "F16:L16" van het tabblad "Teamleider-Productie Dashboard" naar een ander tabblad "Productie-aantal Karren" via copy date, dat werkt perfect als ik getallen typ in de velden "F16:L16".

Nu heb ik de cellen "F16:L16" een som laten berekenen en de getallen die daar uitkomen via dezelfde copy date wegschrijven maar dan krijg ik een 0 op het gekopieerde blad.
Alleen als ik dus geen formule in cel "F16:L16" plaats, en wat getallen in deze cellen typ, kopieert hij zuiver de getypte getallen.

1. wat in onderstaande code moet ik veranderen ?
2. hoe reken ik de som in een andere cel en kopieer ik dat naar cel "F16:L16", want dan staat er ook geen formule in cel "F16:L16" ?

Sub Button2_Click()0 CopyRange "Teamleider-Productie Dashboard", "Productie-aantal Karren", "E16", "F16:L16", 2, 3
End Sub


Private Sub CopyRange(sSN As String, dSN As String, fV As String, sR As String, sC As Long, dC As Long)
On Error GoTo fout_CopyRange
Set sS = ThisWorkbook.Sheets(sSN)
Set dS = ThisWorkbook.Sheets(dSN)
R = False
V1 = sS.Range(fV).Value
If Not IsEmpty(V1) Then
fR = -1
For I = 1 To 1000
V2 = dS.Cells(I, sC).Value
If VarType(V1) = VarType(V2) Then
If V2 = V1 Then
fR = I
Exit For
End If
End If
Next
If fR > -1 Then
sS.Range(sR).Copy dS.Cells(fR, dC)
R = True
End If
End If
If R Then
MsgBox "Data gekopieerd !", vbInformation, "Copy"
Else
MsgBox "Gegeven niet gevonden !", vbExclamation, "Geen Copy"
End If
Exit Sub
fout_CopyRange:
MsgBox "Error, check parameters !", vbInformation, "Fout"
End Sub

 

[emields]

Terug voorbeeldje vergeten?

 

[rogersmeets]

wat bedoel je ik heb de code geplaatst voorbeeld lukt niet

 

[Haije]

Emields bedoelt: Wel de code geplaatst, maar geen bestand

 

[rogersmeets]

hij staat erbij.

Het eerste tabblad teamleider daschboard, (zie foto)daar voeg je in de 3 kollommen getallen in, die worden opgeteld (=som)weergegeven in de kleine blauwe grafiek erboven, door een druk op opslaan schrijft hij deze getallen naar tabblad "jaarproductie aantal karren" met een macro op de button "opslaan" bij de datum die naast de tabel staat.

Doordat er nu een formule in de blauwe getallen tabel staat Kopieert hij deze ook mee naar de jaaropgave en komt daar in conflict.

Hij moet dus de getallen en kleuren mee kopieren niet de formule in de macro.

Bovendien heb ik ook graag dat hij als de grote kolom leeg is zoals nu dat er geen getallen ingevoerd kunnen worden met een pop up scherm "eerst ernaast gelegen formaat kiezen"

hoofdpagina

hier moet ie naartoe kopieren maar zoals je ziet doet ie maar 1 de rest niet

 

[Haije]

wijzig

sS.Range(sR).Copy dS.Cells(fR, dC)

eens in

=dS.Cells(fR, dC).Resize(1, 7) = sS.Range(sR).Value

 

[rogersmeets]

dan geeft ie compileerfout op die verandering in de code

 

[rogersmeets]

nee hij klopt ik heb de = weggelaten uit deze verandering en hij werkt yesssssss

 

[rogersmeets]

klein tweede vraagje wat moet ik in de code veranderen als ik nu wil dat hij naar jaarproductie aantal karren als 2023, in een andere map een apart file los van het programma wil schrijven die ik bij dit programma in een aparte map voeg ?

zo kan de gebruiker los de jaren waarop de data komen erbij voegen, als ik het programma aanpas en de gebruikers hebben hun eigen data toegevoegd dan is die verloren.
Laat ik het hun op aparte files opslaan kunnen ze die weer bij mijn programma voegen, en zo kunnen ze jaarlijks de gegevens in een apart bestand erbij opslaan.
Hij moet dan een gesloten map openen en het bestand jaarproductie aantal karren naar het huidige jaar in die map schrijven.

 

[rogersmeets]

nee hij klopt ik heb de = weggelaten uit deze verandering en hij werkt yesssssss,Alleen de kleuren die de cellen hebben kopieert hij niet mee

 

[HSV]

sS.Range(sR).Copy
dS.Cells(fR, dC).pastespecial xlpastevalues
dS.Cells(fR, dC).pastespecial xlpasteformats
application.cutcopymode = false

 

[rogersmeets]

helaas niet met kleur op het weggeschreven blad

Sub Button2_Click()0 CopyRange "Teamleider-Productie Dashboard", "Productie-aantal Karren", "E16", "F16:L16", 2, 3
End Sub


Private Sub CopyRange(sSN As String, dSN As String, fV As String, sR As String, sC As Long, dC As Long)
On Error GoTo fout_CopyRange
Set sS = ThisWorkbook.Sheets(sSN)
Set dS = ThisWorkbook.Sheets(dSN)
R = False
V1 = sS.Range(fV).Value
If Not IsEmpty(V1) Then
fR = -1
For I = 1 To 1000
V2 = dS.Cells(I, sC).Value
If VarType(V1) = VarType(V2) Then
If V2 = V1 Then
fR = I
Exit For
End If
End If
Next
If fR > -1 Then
sS.Range(sR).Copy
dS.Cells(fR, dC).PasteSpecial xlPasteValues
dS.Cells(fR, dC).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
R = True
End If
End If
If R Then
MsgBox "Data gekopieerd !", vbInformation, "Copy"
Else
MsgBox "Gegeven niet gevonden !", vbExclamation, "Geen Copy"
End If
Exit Sub
fout_CopyRange:
MsgBox "Error, check parameters !", vbInformation, "Fout"
End Sub

 

[rogersmeets]

wordt:

 

[HSV]

Alle cel-kleuren worden overgenomen.

 

[rogersmeets]

dat gebeurt niet de overgenomen cellen blijven blauw

 

[HSV]

Laat me dat eens zien in je bestand.

Onderstaande code doet trouwens precies hetzelfde (netjes met de kleuren), maar loopt geen duizend cellen af zoals in jouw code.

Sub Button2_Click()
Set sh = Sheets("teamleider-productie dashboard")
With Sheets("productie-aantal karren")
  r = Application.Match(sh.Range("e16"), .Columns(2), 0)
  If IsNumeric(r) Then
     sh.Range("f16:l16").Copy
    .Cells(r, 3).PasteSpecial xlPasteValues
    .Cells(r, 3).PasteSpecial xlPasteFormats
    application.cutcopymode = false
  End If
End With
End Sub

 

[rogersmeets]

het bestand bijgevoegd hij verandert de kleur niet mee.
Hoe zou ik naar een map in een ander bestand kunnen schrijven ?? zodat ik naast dit programma in een submap blad jaar produktie voor 2023 24 25 enz kan plaatsen en bewaren

iemand een idee ?

 

[HSV]

Het komt doordat het voorwaardelijke opmaak is die ook mee gekopieerd wordt.
Dat ze niet kleuren komt omdat de voorwaardelijke opmaakformule niet geldt voor dat blad.

Hier een oplossing zonder kopiëren van voorwaardelijke opmaak maar wel de kleuren ervan.

Sub Button2_Click()
Set sh = Sheets("teamleider-productie dashboard")
With Sheets("Jaarproductie-aantal karren")
  r = Application.Match(sh.Range("e15"), .Columns(2), 0)
  If IsNumeric(r) Then
     sh.Range("f15:l15").Copy
     .Cells(r, 3).PasteSpecial xlPasteValues
 Application.CutCopyMode = False
     For Each cl In .Cells(r, 3).Resize(, 7)
       cl.Interior.Color = sh.Range("f15").Offset(, y).DisplayFormat.Interior.Color
        y = y + 1
     Next cl
  End If
End With
End Sub

 

[rogersmeets]

hij functioneert 100% super kerel bedankt !!!

Bij kopieren is heel even het hele beeld weg, kan dat stabieler dat het beeld gewoon stabiel blijft? (hihi)

En als ik jaarproduktie karren nou eens in een nieuw bestand een apart blad dat ik vanuit deze kan opvragen wat verander ik dan ?
Zo kan ik telkns de jaargegevens apart opslaan voor elk jaar los van dit bestand

 

[HSV]

Een bestand aanmaken met de naam "2023.xlsm" in dezelfde map als waar dit bestand ook staat.
Voor volgend jaar maak je een nieuw bestand met de naam 2024.xlsm

Sub Button2_Click()
Application.ScreenUpdating = False
 s00 = ThisWorkbook.Path & "\" & Year(Date) & ".xlsm"
   Set sh = ThisWorkbook.Sheets("teamleider-productie dashboard")
     With Workbooks.Open(s00).Sheets("Jaarproductie-aantal karren")
        r = Application.Match(sh.Range("e15"), .Columns(2), 0)
    If IsNumeric(r) Then
              sh.Range("f15:l15").Copy
              .Cells(r, 3).PasteSpecial xlPasteValues
              Application.CutCopyMode = False
        For Each cl In .Cells(r, 3).Resize(, 7)
            cl.Interior.Color = sh.Range("f15").Offset(, y).DisplayFormat.Interior.Color
            y = y + 1
        Next cl
   End If
 ActiveWorkbook.Close True
End With
End Sub