Userform onder voorwaarden openen en vullen

[Leotaxi]

Dag Siebe,

misschien volgende
heb gezien dat in proefbestand de hernummering in kolom A via een loop gaat
dit kan in een groot bestand meer tijd vergen, dus best dat deel vervangen door

lastrow = Range("a" & Rows.Count).End(xlUp).Row
Range("a6", "a" & lastrow).FormulaR1C1 = "=R[-1]C+1"

mvg
Leo

 

[sb17]

Leo,

Dank voor de reactie het is me alleen niet geheel duidelijk welk deel eruit moet

Siebe

 

[Leotaxi]

Siebe,

ergens onderaan in de code staat nu

for  x =   (vanwaar totwaar)
range("a"&x).value = range("a"&x-1).value +1
next

dit deel vervangen

mvg

Leo

 

[sb17]

Leo,

Bedankt het is nu ca 13 sec een stuk sneller, dit is ws de max?

Siebe

 

[Leotaxi]

Siebe,

misschien nog sneller zonder hernummering van kolom A
wel éénmalig formule in kolom A aanpassen, daarna is geen hernummering meer nodig.



mvg
Leo

 

[Leotaxi]

en dan in deze wel voorzien dat die formule in kolom A ook in de nieuw ingevoegde rij (en) geplaatst wordt.

ook kleine aanpassing in sub telop, die was toch niet 100 % zuiver.


mvg
Leo

 

[sb17]

Leo,

Sorry voor mijn niet reageren, duurt nu ca 5 seconden, stuk opgeknapt en tevens is de subtelop zuiver. bedankt zover.

Siebe

 

[sb17]

Leo,

Op de een of andere manier komen de datums in de uitsplits vakken niet goed als datum te staan, tenminste excel leest ze niet goed als datum, terwijl in jouw bestand nr 8 het wel goed gaat.
Hier de code die ik nu gebruik in zijn geheel, ik zie niet waar het mis gaat, weet jij het?

Sub telop()

    x1 = x1 + Val(txtBedragUitsplits1.Text)
    x2 = x2 + Val(txtBedragUitsplits2.Text)
    x3 = x3 + Val(txtBedragUitsplits3.Text)
    x4 = x4 + Cells(ActiveCell.Row, 5).Value
    x = x4 - x1 - x2 - x3
    Caption = "Transaktie uitsplitsen                                                                                                                                                              " & x
End Sub

Private Sub cmdAnnuleren_Click()
Unload Me
End Sub


Private Sub cmdOkenUitsplitsen_Click()
        Application.ScreenUpdating = False
    x1 = x1 + Val(txtBedragUitsplits1.Text)
    x2 = x2 + Val(txtBedragUitsplits2.Text)
    x3 = x3 + Val(txtBedragUitsplits3.Text)
    
    With Sheets("jan")
          If x1 > 0 Then
            .Range("e" & ActiveCell.Row).Value = ""
            
            With .Range("e" & ActiveCell.Row).Interior
            .Color = 255
            End With
            
            .Range("a" & ActiveCell.Row).Offset(1, 0).EntireRow.Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            .Range("a" & ActiveCell.Row).Offset(-1, 0).EntireRow.Copy Destination:=Range("a" & ActiveCell.Row)
            .Range("b" & ActiveCell.Row).Value = Me.txtGeselecteerdeTransaktieDatum
            .Range("c" & ActiveCell.Row).Value = Me.txtGeselecteerdeTransaktieOmschrijving
            .Range("d" & ActiveCell.Row).Value = Me.txtMededelingUitsplits1
            .Range("e" & ActiveCell.Row).Value = x1
                        With Range("e" & ActiveCell.Row).Interior
                        .Pattern = xlNone
                        End With
            .Range("f" & ActiveCell.Row).Value = Me.txtBijAfUitsplits1
          End If
                If x2 > 0 Then
                    .Range("a" & ActiveCell.Row).Offset(1, 0).EntireRow.Select
                     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("a" & ActiveCell.Row).Offset(-1, 0).EntireRow.Copy Destination:=Range("a" & ActiveCell.Row)
                    .Range("b" & ActiveCell.Row).Value = Me.txtGeselecteerdeTransaktieDatum
                    .Range("c" & ActiveCell.Row).Value = Me.txtGeselecteerdeTransaktieOmschrijving
                    .Range("d" & ActiveCell.Row).Value = Me.txtMededelingUitsplits2
                    .Range("e" & ActiveCell.Row).Value = x2
                        With Range("e" & ActiveCell.Row).Interior
                        .Pattern = xlNone
                        End With
                    
                    .Range("f" & ActiveCell.Row).Value = Me.txtBijAfUitsplits2
                End If
                    
                    If x3 > 0 Then
                    .Range("a" & ActiveCell.Row).Offset(1, 0).EntireRow.Select
                    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("a" & ActiveCell.Row).Offset(-1, 0).EntireRow.Copy Destination:=Range("a" & ActiveCell.Row)
                    .Range("b" & ActiveCell.Row).Value = Me.txtGeselecteerdeTransaktieDatum
                    .Range("c" & ActiveCell.Row).Value = Me.txtGeselecteerdeTransaktieOmschrijving
                    .Range("d" & ActiveCell.Row).Value = Me.txtMededelingUitsplits3
                    .Range("e" & ActiveCell.Row).Value = x3
                             With Range("e" & ActiveCell.Row).Interior
                             .Pattern = xlNone
                             End With
                        .Range("f" & ActiveCell.Row).Value = Me.txtBijAfUitsplits3
                    End If
        End With


Application.ScreenUpdating = True
Unload Me
End Sub




Private Sub txtBedragUitsplits1_Change()
telop
End Sub

Private Sub txtBedragUitsplits2_Change()
telop
End Sub

Private Sub txtBedragUitsplits3_Change()
telop
End Sub

Private Sub UserForm_Initialize()
    

    ar = Sheets("jan").Range("B" & ActiveCell.Row).Resize(, 5)
    txtGeselecteerdeTransaktieDatum = ar(1, 1)
    txtGeselecteerdeTransaktieOmschrijving = ar(1, 2)
    txtGeselecteerdeTransaktieMededeling = ar(1, 3)
    txtGeselecteerdeTransaktieBedrag = ar(1, 4)
    txtGeselecteerdeTransaktieBijAf = ar(1, 5)

txtDatumUitsplits1.Value = Format(CDate(Range("b1").Value), "dd/mm/yyyy")


With Me.txtMededelingUitsplits1

.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
End With

End Sub

nb In de sub tel op blijft soms nog iets 6 of 7 achter de komma over, kun je dit nog weg krijgen?

 

[Leotaxi]

Hoi Siebe,

geen idee wat betreft de datums voor die sub telop had ik in bestand 8 iets aangepast dat ik bij jouw versie niet zie
vergelijk eens.

Sub telop()
    x4 = 0
    x1 = x1 + Val(txtBedragUitsplits1.Text)
    x2 = x2 + Val(txtBedragUitsplits2.Text)
    x3 = x3 + Val(txtBedragUitsplits3.Text)
    x4 = x4 + Cells(ActiveCell.Row, 5).Value
    x = x4 - x1 - x2 - x3
    Caption = "Transaktie uitsplitsen                                                                                                                                                              " & x
End Sub

mvg
Leo