Overzetten data van tabblad

Status
Niet open voor verdere reacties.

DnA51535

Steunend lid
Vip Lid
Hallo allen,
Ik zou graag gegevens van het ene tabblad naar het andere overzetten.
Ik dacht hier aan een macro of dergelijke maar ik ben leek daarin.
De sheet bevat 13 tabbladen, > van tabblad " resultaten" en van "resultaten (2)" > naar JAP 2020, "resultaten" heeft op zich de mogelijkheid om 5 jaar ver te gaan, zodat de resultaten van het jaar naar een ander JAP moet. resultaten 2020 naar JAP 2021, resultaten 2021 naar JAP 2022,
Hopelijk begrijpen jullie wat ik bedoel.

DnA
 
Hey knoet,
dank, betreffende uw opmerking, ik denk dat u dit verkeerd gelezen hebt, ik had wel 21.1 aangeduid en niet 21.6, nu staat het numeriek, vooraleer ik "OK" zeg, zal ik nog enkele testen uitvoeren, > alles loopt goed, efkens wat bijgevuld onderaan de onderwerpen en getest.
Nu, hoe zet ik deze macro over? Ja, sorry eens leek, altijd leek!?
DnA
 
Je hebt wel degelijk 21.6 aangeduid, zie je voorbeeld in Post #30.
Om de code over te zetten, onderaan op het tabblad JAP2020 rechtsklikken -> Programacode weergeven klikken, daar de code kopiëren,daarna hetzelfde doen met je echte blad en daar de code plakken.
De knop kan je ook kopiëren en plakken.
 
In ontwerpmodus, rechterklik op de k,op in het echte voorbeeld -> eigenschappen, in de eerste lijn (Name) CommandButton1 veranderen in Cmd1, terug op ontwerpmodus klikken om ontwerpmodus uit te schakelen.
 
Ok is gelukt, natuurlijk heb ik de kleur van de "voorwaardelijke opmaak" in de resultaten ook in het JAP 2020, en ook, doordat er een automatische nummering toegevoegd is heb ik volgende in de A kolom > =ALS(#VERW!="";""&#VERW!;LINKS(#VERW!; VIND.ALLES(" ";#VERW!)-1) & "."&AANTAL.ALS(#VERW!;#VERW!)), vb, 10 vragen in onderwerp "1 machines" geven 10 genummerde lijnen > 1.1, 1.2, 1.3, tot 1.10,
Kunnen wij alleen de waarden opnemen?
 
Test deze code eens.
Code:
Private Sub Cmd1_Click()

Application.ScreenUpdating = False

Set j20 = Sheets("JAP 2020")
lrJ20 = j20.Cells(Rows.Count, 1).End(xlUp).Row
If lrJ20 < 5 Then lrJ20 = 5
j20.Rows(5 & ":" & lrJ20).ClearContents
    
Set R = Sheets("Resultaten")
GoSub kopieer
    
Set R = Sheets("Resultaten (2)")
GoSub kopieer

For rij = lrJ20 To 5 Step -1
    If j20.Cells(rij, 2) = "" And j20.Cells(rij - 1, 2) = "" Then
        j20.Rows(rij - 1).Delete
    End If
Next rij

Exit Sub

kopieer:
With R
    lrR1 = .Cells(Rows.Count, 4).End(xlUp).Row
    For i = 8 To lrR1
        If .Cells(i, 4) <> "" Then
            lrJ20 = j20.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If .Cells(i, 5) = "" Then
                j20.Cells(lrJ20, "A") = .Cells(i, "D")
                If InStr(1, .Cells(i, 4), ".") = 0 And .Cells(i, 7) = "" And IsNumeric(Left(.Cells(i, 4), 1)) Then
                    .Range("D" & i).Copy j20.Range("A" & lrJ20)
                End If
            Else
                If UCase(.Range("G" & i)) = "X" Then
                  .Range("D" & i & ":E" & i).Copy j20.Range("A" & lrJ20 & ":B" & lrJ20)
                End If
            End If
        End If
    Next i
End With
Return

End Sub
 
knoet, goede middag, niets veranderd, dat de voorwaardelijke opmaak uit de resultaten ook in het JAP 2020 te zien is > geen probleem dat maakt het een beetje overzichtelijker,
dat heb ik nu

1572971936756.png
Wat zien wij, #VERW! met witte regel is het onderwerp #VERW! met het knelpunt zou het knelpuntnummer moeten zijn,
Verder zien wij 21.4 staan in witte regel zou moeten zijn: 21 Beleidsverklaring > onderaan een "x" ??
DnA
 
dat mama en papa komen aankakken is doordat ik een testje gedaan heb om te zien dat de nieuwe gegevens uit "resultaten" weggeschreven worden, dus dat is OK, maar niet 21.4 & x.
formule > =ALS(B9="";""&C9;LINKS(B9; VIND.ALLES(" ";B9)-1) & "."&AANTAL.ALS($B$8:B9;B9))
 
Code:
Private Sub Cmd1_Click()

Application.ScreenUpdating = False

Set j20 = Sheets("JAP 2020")
lrJ20 = j20.Cells(Rows.Count, 1).End(xlUp).Row
If lrJ20 < 5 Then lrJ20 = 5
j20.Rows(5 & ":" & lrJ20).ClearContents
    
Set R = Sheets("Resultaten")
GoSub kopieer
    
Set R = Sheets("Resultaten (2)")
GoSub kopieer

For rij = lrJ20 To 5 Step -1
    If j20.Cells(rij, 2) = "" And j20.Cells(rij - 1, 2) = "" Then
        j20.Rows(rij - 1).Delete
    End If
Next rij

Exit Sub

kopieer:
With R
    lrR1 = .Cells(Rows.Count, 4).End(xlUp).Row
    For i = 8 To lrR1
        If .Cells(i, 4) <> "" Then
            lrJ20 = j20.Cells(Rows.Count, 1).End(xlUp).Row + 1
            j20.Cells(lrJ20, "A") = .Cells(i, "D")
            If .Cells(i, 5) = "" Then
                If InStr(1, .Cells(i, 4), ".") = 0 And .Cells(i, 7) = "" And IsNumeric(Left(.Cells(i, 4), 1)) Then
                    .Range("D" & i).Copy j20.Range("A" & lrJ20)
                End If
            Else
                If UCase(.Range("G" & i)) = "X" Then
                  .Range("D" & i & ":E" & i).Copy j20.Range("A" & lrJ20 & ":B" & lrJ20)
                End If
            End If
        End If
    Next i
End With
Return

End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan