gegevens kopieren naar ander tabblad op bepaalde plaats

[Remlo]

Ik weet niet goed hoe de vraag juist te formuleren...
voorbeeldbestand bijgevoegd om het te verduidelijken.

 

[MarcelBeug]

Ja, dat kan wel, hetzij met een stukje VBA dat alles doet en/of met een extra blad "Weekoverzicht" waarin je de weekgegevens in de juiste layout opneemt voor het totaaloverzicht.

De belangrijkste vraag hier: hoe flexibel wil je het hebben?
Heb je altijd P1 t/m P4 en type A t/m F? Dan is het een kwestie van gegevens kopiëren van hard gecodeerde broncellen naar hard gecodeerde doelcellen.
Als het flexibeler moet, dan wordt het lastiger.

Met wat meer informatie wil ik best een stukje verder uitwerken, zodat je dat dan zelf verder kunt completeren. Anders gaat het op werken lijken.

 

[Remlo]

Alvast bedankt om het eens te bekijken

De belangrijkste vraag hier: hoe flexibel wil je het hebben?
Heb je altijd P1 t/m P4 en type A t/m F? Dan is het een kwestie van gegevens kopiëren van hard gecodeerde broncellen naar hard gecodeerde doelcellen.

Het is inderdaad altijd P1 t/m P4 en type A t/m F.

In VBA zou ik rijnummer van de datum moeten zoeken en daarna inderdaad op vaste kolommen kopieren.
Maar VBA is niet echt mijn ding.. tot hiertoe

 

[MarcelBeug]

Bekijk bijlage Weekgegevens naar totaaloverzicht kopiëren.xlsb

Zie bijlage. Op het blad Totaaloverzicht heb ik met aangepast nummerformaat 0;;; de nullen onderdrukt.
In extra blad 'WeekOverzicht' heb ik op rij 5 de formules ingevuld. De overige rijen moet je zelf nog doen (behalve datum/dag, die heb ik al gedaan).

Onderstaand even de macro code, zodat een wat meer ervaren VBA-er hier eventueel nog wat over kan zeggen...

Sub Kopieerweekdata()

    Dim CelDatumFound As Range
    
    Dim DoelStartCel As Range
    
    With Sheets("TotaalOverzicht").Range("E:E")
        Set CelDatumFound = .Find(What:=Sheets("WeekOverzicht").Range("A5").Value, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
    End With
    
    If CelDatumFound Is Nothing Then
        MsgBox "Datum niet gevonden in TotaalOverzicht"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Set DoelStartCel = CelDatumFound.Offset(0, 2)
    Sheets("WeekOverzicht").Range("C5:AL11").Copy
    DoelStartCel.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
        
End Sub

 

[MarcelBeug]

Ik zal vanavond nog even kijken of de gegevens met VBA eenvoudig in 1 stap kunnen worden gekopieerd, zonder extra werkblad.

 

[MarcelBeug]

Bekijk bijlage Weekgegevens naar totaaloverzicht kopiëren v2.xlsb

In de bijlage nu met kopieerslag in 1 stap.

De code is opgezet met het oog op duidelijkheid.

Ik heb de oorspronkelijke kolom AA uit het Totaaloverzicht verwijderd. Dat was een extra kolom die de systematiek verstoorde...

Option Explicit

Sub Kopieerweekdata()

    Const AantalProducten As Integer = 4
    Const AantalTypen As Integer = 7
    Const AantalDagen As Integer = 7
    Dim ProductenTeller As Integer
    Dim TypenTeller As Integer
    Dim DagenTeller As Integer
    Dim BronRijOffset As Integer
    Dim BronKolomOffset As Integer
    Dim DoelRijOffset As Integer
    Dim DoelKolomOffset As Integer
    Dim CelDatumFound As Range
    Dim BronStartCel As Range
    Dim DoelStartCel As Range
    
    
    With Sheets("TotaalOverzicht").Range("E:E")
        Set CelDatumFound = .Find(What:=Sheets("Invulblad").Range("F1").Value, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
    End With
    
    If CelDatumFound Is Nothing Then
        MsgBox ("Datum niet gevonden in TotaalOverzicht")
        Exit Sub
    End If
    
    Set BronStartCel = Sheets("Invulblad").Range("C3")
    Set DoelStartCel = CelDatumFound.Offset(0, 2)
    
    Application.ScreenUpdating = False
    For DagenTeller = 1 To AantalDagen
        For TypenTeller = 1 To AantalTypen
            For ProductenTeller = 1 To AantalProducten
                BronRijOffset = (DagenTeller - 1) * 7 + TypenTeller - 1
                BronKolomOffset = ProductenTeller - 1
                DoelRijOffset = DagenTeller - 1
                DoelKolomOffset = (TypenTeller - 1) * 5 + ProductenTeller
                DoelStartCel.Offset(DoelRijOffset, DoelKolomOffset).Value = BronStartCel.Offset(BronRijOffset, BronKolomOffset).Value
            Next ProductenTeller
        Next TypenTeller
    Next DagenTeller
    
    Application.ScreenUpdating = True
    
    MsgBox "Gegevens toegevoegd aan TotaalOverzicht."
        
End Sub

 

[HSV]

Een lusje minder en iets minder variabelen.

Sub hsv()
Dim i As Long, j As Long, c As Range, y As Long, n As Long
Application.ScreenUpdating = False
With Blad1
 Set c = Blad3.Columns(5).Find(.[f1], , xlValues, xlWhole)
  If Not c Is Nothing Then
     For i = 3 To 51 Step 7
       For j = 3 To 36 Step 5
          c.Offset(y, j).Resize(, 4) = .Cells(3, 3).Offset(n).Resize(, 4).Value
          n = n + 1
       Next j
          y = y + 1
       Next i
     MsgBox "verwerkt"
   Else
     MsgBox "datum niet gevonden"
  End If
 End With
End Sub

 

[Remlo]

Heren,

hartelijk dank voor jullie oplossingen.
Ga dit trachten te doorgronden

De oplossing van MarcelBeug had ik vlug getest en uiteraard werkt dit, nogmaals dank

 

[MarcelBeug]

Mooi toch, om een oplossing zo te zien evolueren? :thumb:

 

[HSV]

Hier ook nog maar in een array.

Sub hsv_2()
Dim sn, i As Long, n As Long, j As Long, y As Long, c As Range
sn = Blad1.Range("c3:ao51")
y = 1
n = 1
For i = 1 To UBound(sn)
  For j = 1 To 34
      sn(y, j) = sn(i, n)
             n = n + 1
        If j Mod 5 = 0 Then
           i = i + 1
           n = 1
         End If
         If n Mod 5 = 0 Then n = n + 1
    Next j
    n = 1
  y = y + 1
 Next i
Set c = Blad3.Columns(5).Find(Blad1.Cells(1, 6), , xlValues, xlWhole)
  If Not c Is Nothing Then
     c.Offset(, 3).Resize(7, 35) = sn
     MsgBox "verwerkt"
  Else
     MsgBox "datum niet gevonden"
 End If
End Sub

 

[Remlo]

HSV,

heb jou code ook getest, deze is niet alleen veel kleiner maar werkt ook veel sneller.
Voor mij is het echter moeilijk om te begrijpen wat er nu juist gebeurd.

Hartelijk dank nogmaals aan beide heren