Excel gegevens automatisch ordenen

[Dutchy1]

Goedendag,

Ik heb een excel formulier en als ik hier gegevens invul komen deze te staan in het blad Sheet1, waarna ik ze met een VBA over wil zetten en hierbij heb ik hulp nodig aangezien ik er niet uitkom.
Is er iemand die mij hiermee zou kunnen helpen?

Voorbeeld:
Project - Omschrijving - Uren
9000 - Werk 1 - 8
9001 - Werk 2 - 8

Als ik bovenstaande gegevens in mijn formulier invuld wordt dit weergegeven in Sheet1. Nu is mijn bedoel dat hij deze waarde niet plak in Sheet 1 maar eigenlijk in het bijbehorende tabblad met de naam van het projectnummer. Dus dat hij Werk 1 met 8 uur in tabblad 9000 zet.
Ik heb een losse VBA en als ik die run dan plakt hij het in het tabblad wat ik opgeef zoals hoe ik het graag zou willen alleen dan zit ik ermee dat ik tal van projecten handmatig moet voorcoderen en zodra er elke keer een nieuw project bijkomt ik dus mijn VBA moet aanpassen wat niet mijn bedoeling is.

Mijn bedoeling is dat het programma zelf kijkt in A2, A3, A4 etc welk nummer daar staat vermeld en dan de gegevens plakt in het goede tabblad.

In mijn VBA voor zelf handmatig omzetten staat:

lastrow = Sheets("[B][U]9000[/U][/B]").Range("A65536").End(xlUp).Row + 1
Range("A2:K2").Copy Destination:=Sheets("[B][U]9000[/U][/B]").Range("A" & lastrow)

En nu is het dus de bedoeling dat de hierboven weergegeven 9000 niet ingevuld is door mij zelf maar dat hij deze waarde haalt uit cel A2.

Is er iemand die mij dus kan uitleggen hoe ik tegen excel zeg dat hij de dikgedrukte en onderstreepte 9000 vervangt door de waarde die in cel A2 opgegeven is?

Alvast bedankt!

Mvg

......
Wat ik nu heb als VBA waarmee het niet werk is:

Sub Get_Data()
Dim lastrow As Long

Set Project1 = Sheet1.Range("A2")
lastrow = Sheets("Project1").Range("A65536").End(xlUp).Row + 1
Range("A2:K2").Copy Destination:=Sheets("Project1").Range("A" & lastrow)

Set Project2 = Sheet1.Range("A3")
lastrow = Sheets("Project2").Range("A65536").End(xlUp).Row + 1
Range("A3:K3").Copy Destination:=Sheets("Project2").Range("A" & lastrow)

End Sub

 

[Warme bakkertje]

Plaats je bestandje met je formulier en de code die je tot nu toe gemaakt hebt.

 

[Dutchy1]

Beste Warme Bakkertje,

Ik hoop dat het gelukt is om het bestand te uploaden, kon het namelijk niet via bericht en dan bijlage doen aangezien hij te groot is?

http://www.filedropper.com/test1_4

Mvg

 

[Warme bakkertje]

Sub Get_Data()
    With Sheet1
        For i = 2 To .Range("A65536").End(xlUp).Row
            .Cells(i, 1).Resize(, 11).Copy Sheets(CStr(.Cells(i, 1).Value)).Range("A65536").End(xlUp).Offset(1)
        Next
    End With
End Sub

 

[Dutchy1]

Beste Warme Bakkertje,

Bedankt! Hiermee ben ik heel erg geholpen.

Nu moet ik dus een knop maken waarmee ik die VBA kan afspelen, maar is het ook mogelijk dat ik na het drukken op die knop excel alles dus verdeeld en daarna Sheet 1 ingevulde gegevens weglaat?

Dus ik vul mijn formulier in, deze gegevens komen in Sheet 1 te staan. Daarna laat ik alles sorteren op datum e.d. en druk ik op een knop 'ordenen op basis van projecten' en dan verdeeld die het dmv jou geschreven VBA en dan uiteindelijk is alles verdeeld en is Sheet 1 ingevulde tekst door het formulier weer leeg.

 

[Timshel]

Probeer het eens zo. Dan heb je die hele sheet1 niet nodig.
Je kunt het formulier oproepen met CTRL SHIFT - F.

 

[Dutchy1]

Beste Timshel,

Heel erg bedankt! Dat is precies het eindresultaat wat ik wilde behalen.

Dit topic kan gesloten worden, ik ben meer dan genoeg geholpen! Bedankt!

 

[Dutchy1]

Probeer het eens zo. Dan heb je die hele sheet1 niet nodig.
Je kunt het formulier oproepen met CTRL SHIFT - F.

Beste Timshel,

Zodra ik nu de uren invul zoals 0.5uur (dmv de cijfers rechts van mijn toetsenbord) komt er in het vakje een . te staan en daarna in het excel bestand een . ipv een ,

Hierdoor kan excel het totaal bedrag niet berekenen. Hoe kan ik dit het beste oplossen?
Ik heb de cel al de eigenschappen gegeven van getal, maar dan blijft hij nogsteeds 0.5 ipv 0,5 (tenzij ik het handmatig aanpas maar ik wil dat hij dit automatisch doet).

Kunt u mij hiermee verder helpen m.b.t. het toegevoegde bestand van jezelf.

Mvg

 

[Timshel]

Het makkelijkst is onderstaande aanpassing te maken in de verwerkingsroutine:

Private Sub Verwerkknop1_Click()
    Dim i As Long
    Dim Sh As Object
    Dim lLr As Long
    Dim Arr
        
    For i = 1 To 25
        On Error Resume Next
        Set Sh = Sheets(CStr(Me("Pr" & i)))
        If Err.Number = 0 Then
            lLr = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
            [COLOR="#FF0000"]Arr = Array(Sh.Name, Me("Datum" & i), Me("Werk" & i), Replace(Me("Uren" & i), ".", ","), Me("Werkn" & i), "x", _
                Replace(Me("Tarief" & i), ".", ","), "'=", 0, Me("KM" & i), Me("Bon" & i))[/COLOR]
            Sh.Cells(lLr, 1).Resize(, 11) = Arr
            Sh.Cells(lLr, 9).FormulaR1C1 = "=RC[-5]*RC[-2]"
        Else
            If CStr(Me("Pr" & i)) <> "" Then MsgBox "Project " & CStr(Me("Pr" & i)) & " bestaat niet!"
        End If
        On Error GoTo 0
    Next
    If MsgBox("De uren zijn bijgeschreven." & vbLf & "Wilt u meer regels invoeren?", vbYesNo, "Voortgang") = vbYes Then
        For i = 1 To 25
            Me("Pr" & i) = ""
            Me("Datum" & i) = ""
            Me("Werk" & i) = ""
            Me("Uren" & i) = ""
            Me("Werkn" & i) = ""
            Me("Tarief" & i) = ""
            Me("KM" & i) = ""
            Me("Bon" & i) = ""
        Next
        Pr1.SetFocus
    Else
        Unload Me
    End If
End Sub

 

[Dutchy1]

Wederom heel erg bedankt!

Ik had de replace erna gezet en kreeg steeds foutmeldingen, had hem ook al geplaatst in de " Me("Uren" & i) = "" " regel en werkte ookal niet haha.

Nu werkt hij precies zoals ik het wil hebben. Erg bedankt!