Celwaarden vastleggen in een andere cel

[swedjam]

Hej

Ik wil in een werkmap die een aantal werkbladen bevat het volgende kunnen uitvoeren:
- Waarden, die via een formule worden berekend, op gezette tijden in een andere cel vastleggen (dus alleen de waarde, niet de formule).
- De volgende keer moeten de waarden in de cel eronder worden weggeschreven (dus niet overschrijven).
Zo onstaat er een historisch overzicht van waarden.
Ergens op het forum vond ik dit stukje code

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(False, False) = "B1" Then
Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Target
End If
End Sub

Voor 1 cel werkt dit maar ik heb bijv. de cellen A1 t/m A10 op 10 werkbladen die ik zou willen vastleggen.

Wie helpt mij een stukje verder op weg?

MVG Olaf

 

[Niels28]

begrijp ik het goed dat A1 naar bv tabblad 2 gaat en A2 naar tabblad 3 enz...

Dan kan dat zo:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Sheets(Target.Row + 1).Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = Target.Value
End If
End Sub

Ga ervanuit dat sheets(2) het blad is waar a1 naar gekopieerd moet worden, als dit anders is moet je de +1 aanpassen.

Niels

 

[swedjam]

Hej Niels,
Alvast bedankt voor je snelle reactie.
De bedoeling is dat de waarden in hetzelfde tabblad komen te staan. En dat dus voor een aantal verschillende tabbladen.

Olaf

 

[Niels28]

Als het om alle tabbladen gaat dit achter Thisworkbook zetten

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
activesheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = Target.Value
End If
End Sub

Niels

 

[swedjam]

Niels ik kon je niet helemaal volgen. Wat bedoel je met "dit achter Thisworkbook zetten"?
En dan is het nog niet helemaal wat ik zou willen.
De waarden die in de cellen A1 t/m J1 berekend zijn moeten worden weggeschreven op hetzelfde werkblad in A5 t/m J5. Dit moet dan gebeuren na een startcommando, dus niet na iedere verandering op het werkblad.

Olaf

 

[Niels28]

Geef eens een voorbeeld bestandje , geef even aan wat je waar wilt hebben en hoe.

Niels

 

[Warme bakkertje]

Als ik je uitleg goed begrepen heb.

Sub tst()
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Range("A1:J1").Copy
        If sh.Cells(5, 1) = "" Then
            sh.Cells(5, 1).PasteSpecial xlPasteValues
        Else
            sh.Range("A" & sh.Cells(Rows.Count, 1).End(xlUp).Row).Offset(1) _
                    .PasteSpecial xlPasteValues
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

 

[swedjam]

Geweldig Rudi, het werkt!
Om te kunnen begrijpen wat er gebeurt zou ik graag de code een beetje vertaald hebben. Kun je per regel vertellen kort wat die doet?
Dan kan ik het zelf misschien aanpassen aan verder wensen. Bijvoorbeeld dat macro niet, zoals nu, op alle tabbladen tegelijk werkt en niet met dezelfde range.
Dus per tabblad verschillend.

Olaf

 

[Warme bakkertje]

Nu werkt hij enkel op het actieve werkblad + woordje uitleg

Sub tst()
    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("A1:J1").Copy 'te kopieëren bereik
        If .Cells(5, 1) = "" Then 'kijk of cel A5 leeg is
            ' indien ja
            .Cells(5, 1).PasteSpecial xlPasteValues 'celwaarden plakken
        Else
            ' indien niet leeg zoek eerstvolgende lege cel in kolom A
            .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row) _
                .Offset(1).PasteSpecial xlPasteValues
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

 

[swedjam]

Werkt nog beter! Slechts een kleine correctie: vervang "Next" door "End With".

Nogmaals bedankt,

Olaf

 

[Warme bakkertje]

Nogmaals bewezen, ' Haast en spoed is zelden goed '
Markeer je de vraag dan nog even als opgelost.