procedure te groot

barbaar · 20 mei 2008

Ik heb met VBA een klein probleempje. Ik heb namelijk een procedure geschreven in vba, maar deze is te groot. Ik zal hieronder een klein stukje plakken.

Code:

Private Sub CommandButtonVerwerkDistributie_Click()
If CheckBox1.Value = True Then
If Worksheets("Distributiescherm").Range("A4") = "" Then
CheckBox1.Value = False
Else
If Application.WorksheetFunction.CountA(Range("A4:E4")) < 5 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
LR = Worksheets("Distributie historie").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Distributie historie")
    .Cells(LR, 1) = Sheets("Distributiescherm").Cells(4, 1)
    .Cells(LR, 2) = Sheets("Distributiescherm").Cells(4, 2)
    .Cells(LR, 3) = Sheets("Distributiescherm").Cells(4, 3)
    .Cells(LR, 4) = Sheets("Distributiescherm").Cells(4, 4)
    .Cells(LR, 5) = Sheets("Distributiescherm").Cells(4, 5)
    .Cells(LR, 6) = Sheets("Distributiescherm").Cells(4, 6)
    .Cells(LR, 7) = Sheets("Distributiescherm").Cells(4, 7)
    .Cells(LR, 8) = Sheets("Distributiescherm").Cells(4, 8)
End With
Select Case Range("A4").Value
    Case "sk335126"
If Worksheets("Voorraadverloop").Range("A6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("A5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 1) = Sheets("Voorraadscherm").Cells(4, 1)
    .Cells(LR, 3) = Sheets("Voorraadscherm").Cells(4, 3)
    .Cells(LR, 4) = Sheets("Voorraadscherm").Cells(4, 4)
    .Cells(LR, 5) = Sheets("Voorraadscherm").Cells(4, 5)
End With
    Case "rt3623223"
If Worksheets("Voorraadverloop").Range("I6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("I5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 9) = Sheets("Voorraadscherm").Cells(4, 1)
    .Cells(LR, 11) = Sheets("Voorraadscherm").Cells(4, 3)
    .Cells(LR, 12) = Sheets("Voorraadscherm").Cells(4, 4)
    .Cells(LR, 13) = Sheets("Voorraadscherm").Cells(4, 5)
End With
    Case "123"
If Worksheets("Voorraadverloop").Range("Q6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("Q5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 17) = Sheets("Voorraadscherm").Cells(4, 1)
    .Cells(LR, 19) = Sheets("Voorraadscherm").Cells(4, 3)
    .Cells(LR, 20) = Sheets("Voorraadscherm").Cells(4, 4)
    .Cells(LR, 21) = Sheets("Voorraadscherm").Cells(4, 5)
End With
    Case "456"
If Worksheets("Voorraadverloop").Range("Y6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("Y5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 25) = Sheets("Voorraadscherm").Cells(4, 1)
    .Cells(LR, 27) = Sheets("Voorraadscherm").Cells(4, 3)
    .Cells(LR, 28) = Sheets("Voorraadscherm").Cells(4, 4)
    .Cells(LR, 29) = Sheets("Voorraadscherm").Cells(4, 5)
End With
End Select
CheckBox1.Value = False
    Sheets("Distributiescherm").Range("A4:E4").ClearContents
End If
End If
If CheckBox2.Value = True Then
If Worksheets("Distributiescherm").Range("A5") = "" Then
CheckBox2.Value = False
Else
If Application.WorksheetFunction.CountA(Range("A5:E5")) < 5 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
LR = Worksheets("Distributie historie").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Distributie historie")
    .Cells(LR, 1) = Sheets("Distributiescherm").Cells(5, 1)
    .Cells(LR, 2) = Sheets("Distributiescherm").Cells(5, 2)
    .Cells(LR, 3) = Sheets("Distributiescherm").Cells(5, 3)
    .Cells(LR, 4) = Sheets("Distributiescherm").Cells(5, 4)
    .Cells(LR, 5) = Sheets("Distributiescherm").Cells(5, 5)
    .Cells(LR, 6) = Sheets("Distributiescherm").Cells(5, 6)
    .Cells(LR, 7) = Sheets("Distributiescherm").Cells(5, 7)
    .Cells(LR, 8) = Sheets("Distributiescherm").Cells(5, 8)
End With
Select Case Range("A5").Value
    Case "sk335126"
If Worksheets("Voorraadverloop").Range("A6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("A5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 1) = Sheets("Voorraadscherm").Cells(5, 1)
    .Cells(LR, 3) = Sheets("Voorraadscherm").Cells(5, 3)
    .Cells(LR, 4) = Sheets("Voorraadscherm").Cells(5, 4)
    .Cells(LR, 5) = Sheets("Voorraadscherm").Cells(5, 5)
End With
    Case "rt3623223"
If Worksheets("Voorraadverloop").Range("I6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("I5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 9) = Sheets("Voorraadscherm").Cells(5, 1)
    .Cells(LR, 11) = Sheets("Voorraadscherm").Cells(5, 3)
    .Cells(LR, 12) = Sheets("Voorraadscherm").Cells(5, 4)
    .Cells(LR, 13) = Sheets("Voorraadscherm").Cells(5, 5)
End With
    Case "123"
If Worksheets("Voorraadverloop").Range("Q6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("Q5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 17) = Sheets("Voorraadscherm").Cells(5, 1)
    .Cells(LR, 19) = Sheets("Voorraadscherm").Cells(5, 3)
    .Cells(LR, 20) = Sheets("Voorraadscherm").Cells(5, 4)
    .Cells(LR, 21) = Sheets("Voorraadscherm").Cells(5, 5)
End With
    Case "456"
If Worksheets("Voorraadverloop").Range("Y6") = "" Then
    LR = 6
Else
    LR = Worksheets("Voorraadverloop").Range("Y5").End(xlDown).Row + 1
End If
With Sheets("Voorraadverloop")
    .Cells(LR, 25) = Sheets("Voorraadscherm").Cells(5, 1)
    .Cells(LR, 27) = Sheets("Voorraadscherm").Cells(5, 3)
    .Cells(LR, 28) = Sheets("Voorraadscherm").Cells(5, 4)
    .Cells(LR, 29) = Sheets("Voorraadscherm").Cells(5, 5)
End With
End Select
CheckBox2.Value = False
    Sheets("Distributiescherm").Range("A5:E5").ClearContents
End If
End If

Deze code gaat tot checkbox 20 door. Dit wordt niet door vba geaccepteerd. Heeft iemand een idee om deze code in te korten? Op dit moment wordt er per checkbox gekeken welk product het is. Hier valt een hoop op te schrappen, maar ik zou niet weten hoe

Ik hoop dat jullie mij kunnen helpen :thumb:

Roncancio · 20 mei 2008

Ik zie o.a. in de code dat er gezocht wordt naar werkblad Distributie historie.
Deze zie ik echter niet terug in het bestand.

Met vriendelijke groet,

Roncancio

barbaar · 20 mei 2008

Roncancio zei:
Ik zie o.a. in de code dat er gezocht wordt naar werkblad Distributie historie.
Deze zie ik echter niet terug in het bestand.

Met vriendelijke groet,

Roncancio

Ik heb ook geen bestand toegevoegd.

Er wordt wel geschreven naar het tabblad distributie historie, maar ook naar het
distributiescherm.

Het totale bestand kan ik niet toevoegen, het is namelijk te groot

Ik zou het eventueel kunnen mailen als je wilt.

Hoornvan · 20 mei 2008

Hallo barbaar,

Ik zou het niet weten maar de heer Roncancio weet er meer van dan ik.

Dit heeft niets te maken met je vraag maar omdat het over de zelfde file gaat.

Deze code moet je onde de knop Invoeren zetten dan worden de kolom Nog op voorraad en Aantal ook bijgewerkt. Of had je dit al gedaan?
Misschien kan dit ook korter? maar het werkt wel.

Code:

Private Sub CommandButtonInvoer_Click()
If Application.WorksheetFunction.CountA(Range("A4:C4")) < 3 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
LR = Worksheets("Inkoophistorie").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Inkoophistorie")
    .Cells(LR, 1) = Sheets("Voorraad + invoer").Cells(4, 1)
    .Cells(LR, 2) = Sheets("Voorraad + invoer").Cells(4, 2)
    .Cells(LR, 3) = Sheets("Voorraad + invoer").Cells(4, 3)
End With
LR = Worksheets("Voorraadhistorie").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Voorraadhistorie")
    .Cells(LR, 1) = Sheets("Voorraad + invoer").Cells(4, 1)
    .Cells(LR, 2) = Sheets("Voorraad + invoer").Cells(4, 2)
    .Cells(LR, 3) = Sheets("Voorraad + invoer").Cells(4, 3)
    .Cells(LR, 4) = Sheets("Voorraad + invoer").Cells(4, 4)
Dim oudb1 As Long
Select Case Range("A4").Value
    Case "Appels"
        oudb1 = Range("B11").Value
        Range("B11").Value = oudb1 + Range("B4").Value
    Case "Banaan"
        oudb1 = Range("B12").Value
        Range("B12").Value = oudb1 + Range("B4").Value
    Case "Kersen"
        oudb1 = Range("B13").Value
        Range("B13").Value = oudb1 + Range("B4").Value
    Case "Kiwi"
        oudb1 = Range("B14").Value
        Range("B14").Value = oudb1 + Range("B4").Value
    Case "Peren"
        oudb1 = Range("B15").Value
        Range("B15").Value = oudb1 + Range("B4").Value
    Case "Sinaasappel"
        oudb1 = Range("B16").Value
        Range("B16").Value = oudb1 + Range("B4").Value
End Select
Dim oudb2 As Long
Select Case Range("A4").Value
    Case "Appels"
        oudb2 = Range("E11").Value
        Range("E11").Value = oudb2 + Range("B4").Value
    Case "Banaan"
        oudb2 = Range("E12").Value
        Range("E12").Value = oudb2 + Range("B4").Value
    Case "Kersen"
        oudb2 = Range("E13").Value
        Range("E13").Value = oudb2 + Range("B4").Value
    Case "Kiwi"
        oudb21 = Range("E14").Value
        Range("E14").Value = oudb2 + Range("B4").Value
    Case "Peren"
        oudb2 = Range("E15").Value
        Range("E15").Value = oudb2 + Range("B4").Value
    Case "Sinaasappel"
        oudb2 = Range("E16").Value
        Range("E16").Value = oudb2 + Range("B4").Value
End Select
End With
    Sheets("Voorraad + invoer").Range("A4:B4").ClearContents
End Sub

Private Sub CommandButtonVerkoop_Click()
If Application.WorksheetFunction.CountA(Range("H4:K4")) < 4 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
LR = Worksheets("Distributiescherm").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Distributiescherm")
    .Cells(LR, 1) = Sheets("Voorraad + invoer").Cells(4, 8)
    .Cells(LR, 2) = Sheets("Voorraad + invoer").Cells(4, 9)
    .Cells(LR, 4) = Sheets("Voorraad + invoer").Cells(4, 10)
    .Cells(LR, 3) = Sheets("Voorraad + invoer").Cells(4, 11)
End With
    NieuweVoorraad
End Sub
Private Sub NieuweVoorraad()
Dim oudb1 As Long
Select Case Range("H4").Value
    Case "Appels"
        oudb1 = Range("E11").Value
        Range("E11").Value = oudb1 - Range("I4").Value
    Case "Banaan"
        oudb1 = Range("E12").Value
        Range("E12").Value = oudb1 - Range("I4").Value
    Case "Kersen"
        oudb1 = Range("E13").Value
        Range("E13").Value = oudb1 - Range("I4").Value
    Case "Kiwi"
        oudb1 = Range("E14").Value
        Range("E14").Value = oudb1 - Range("I4").Value
    Case "Peren"
        oudb1 = Range("E15").Value
        Range("E15").Value = oudb1 - Range("I4").Value
    Case "Sinaasappel"
        oudb1 = Range("E16").Value
        Range("E16").Value = oudb1 - Range("I4").Value
End Select
    Sheets("Voorraad + invoer").Range("H4:I4").ClearContents
    Sheets("Voorraad + invoer").Range("K4").ClearContents
End Sub

De formule op het bladVoorraadhistorie heb ik ook veranderd.

Code:

=ALS(A4="";"";ALS(D4="Inkoop";VERT.ZOEKEN(A4;'Voorraad + invoer'!$A$11:$C$16;2;ONWAAR);VERT.ZOEKEN(A4;'Voorraad + invoer'!$A$11:$C$16;2;ONWAAR)))

barbaar · 20 mei 2008

Hoornvan zei:

Hallo barbaar,

Ik zou het niet weten maar de heer Roncancio weet er meer van dan ik.

Dit heeft niets te maken met je vraag maar omdat het over de zelfde file gaat.

Deze code moet je onde de knop Invoeren zetten dan worden de kolom Nog op voorraad en Aantal ook bijgewerkt. Of had je dit al gedaan?
Misschien kan dit ook korter? maar het werkt wel.

Code:

Private Sub CommandButtonInvoer_Click()
If Application.WorksheetFunction.CountA(Range("A4:C4")) < 3 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
LR = Worksheets("Inkoophistorie").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Inkoophistorie")
    .Cells(LR, 1) = Sheets("Voorraad + invoer").Cells(4, 1)
    .Cells(LR, 2) = Sheets("Voorraad + invoer").Cells(4, 2)
    .Cells(LR, 3) = Sheets("Voorraad + invoer").Cells(4, 3)
End With
LR = Worksheets("Voorraadhistorie").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Voorraadhistorie")
    .Cells(LR, 1) = Sheets("Voorraad + invoer").Cells(4, 1)
    .Cells(LR, 2) = Sheets("Voorraad + invoer").Cells(4, 2)
    .Cells(LR, 3) = Sheets("Voorraad + invoer").Cells(4, 3)
    .Cells(LR, 4) = Sheets("Voorraad + invoer").Cells(4, 4)
Dim oudb1 As Long
Select Case Range("A4").Value
    Case "Appels"
        oudb1 = Range("B11").Value
        Range("B11").Value = oudb1 + Range("B4").Value
    Case "Banaan"
        oudb1 = Range("B12").Value
        Range("B12").Value = oudb1 + Range("B4").Value
    Case "Kersen"
        oudb1 = Range("B13").Value
        Range("B13").Value = oudb1 + Range("B4").Value
    Case "Kiwi"
        oudb1 = Range("B14").Value
        Range("B14").Value = oudb1 + Range("B4").Value
    Case "Peren"
        oudb1 = Range("B15").Value
        Range("B15").Value = oudb1 + Range("B4").Value
    Case "Sinaasappel"
        oudb1 = Range("B16").Value
        Range("B16").Value = oudb1 + Range("B4").Value
End Select
Dim oudb2 As Long
Select Case Range("A4").Value
    Case "Appels"
        oudb2 = Range("E11").Value
        Range("E11").Value = oudb2 + Range("B4").Value
    Case "Banaan"
        oudb2 = Range("E12").Value
        Range("E12").Value = oudb2 + Range("B4").Value
    Case "Kersen"
        oudb2 = Range("E13").Value
        Range("E13").Value = oudb2 + Range("B4").Value
    Case "Kiwi"
        oudb21 = Range("E14").Value
        Range("E14").Value = oudb2 + Range("B4").Value
    Case "Peren"
        oudb2 = Range("E15").Value
        Range("E15").Value = oudb2 + Range("B4").Value
    Case "Sinaasappel"
        oudb2 = Range("E16").Value
        Range("E16").Value = oudb2 + Range("B4").Value
End Select
End With
    Sheets("Voorraad + invoer").Range("A4:B4").ClearContents
End Sub

Private Sub CommandButtonVerkoop_Click()
If Application.WorksheetFunction.CountA(Range("H4:K4")) < 4 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
LR = Worksheets("Distributiescherm").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Distributiescherm")
    .Cells(LR, 1) = Sheets("Voorraad + invoer").Cells(4, 8)
    .Cells(LR, 2) = Sheets("Voorraad + invoer").Cells(4, 9)
    .Cells(LR, 4) = Sheets("Voorraad + invoer").Cells(4, 10)
    .Cells(LR, 3) = Sheets("Voorraad + invoer").Cells(4, 11)
End With
    NieuweVoorraad
End Sub
Private Sub NieuweVoorraad()
Dim oudb1 As Long
Select Case Range("H4").Value
    Case "Appels"
        oudb1 = Range("E11").Value
        Range("E11").Value = oudb1 - Range("I4").Value
    Case "Banaan"
        oudb1 = Range("E12").Value
        Range("E12").Value = oudb1 - Range("I4").Value
    Case "Kersen"
        oudb1 = Range("E13").Value
        Range("E13").Value = oudb1 - Range("I4").Value
    Case "Kiwi"
        oudb1 = Range("E14").Value
        Range("E14").Value = oudb1 - Range("I4").Value
    Case "Peren"
        oudb1 = Range("E15").Value
        Range("E15").Value = oudb1 - Range("I4").Value
    Case "Sinaasappel"
        oudb1 = Range("E16").Value
        Range("E16").Value = oudb1 - Range("I4").Value
End Select
    Sheets("Voorraad + invoer").Range("H4:I4").ClearContents
    Sheets("Voorraad + invoer").Range("K4").ClearContents
End Sub

De formule op het bladVoorraadhistorie heb ik ook veranderd.

Code:

=ALS(A4="";"";ALS(D4="Inkoop";VERT.ZOEKEN(A4;'Voorraad + invoer'!$A$11:$C$16;2;ONWAAR);VERT.ZOEKEN(A4;'Voorraad + invoer'!$A$11:$C$16;2;ONWAAR)))

Hoi Wim,

Ik was hier ook al mee bezig, maar ben bang dat de code uiteindelijk dan alsnog te groot wordt naar mate het bestand zal groeien.

Ik had trouwens nog een klein vraagje aan je. Waar staat oudb1 precies voor?

Mvg,

barbaar

Hoornvan · 20 mei 2008

Hoi barbaar,

De vorige keer had ik je al geschreven dat ik van macro's ook niet veel weet.
Dus als ik een stukje interesante code tegen kom sla ik deze dan op.
Ik denk dat oudb1 een variable is die het geen in B11 staat onthoud, als je oud neem zal het ook wel werken.

Mvg,
Wim

Wigi · 20 mei 2008

Wellicht helpt de info op deze pagina al heel veel:

http://www.ozgrid.com/VBA/control-loop.htm

Wigi

barbaar · 20 mei 2008

Wigi, ik heb even gegeken, maar snap er eigenlijk niets van

Ik heb wel iets anders gevonden waarmee ik een heel eind gekomen ben. Dit is deze code

Code:

Sub vinden()
    Dim FindString As String
    Dim Rng As Range
    FindString = Range("A21")
    If Trim(FindString) <> "" Then
        With Sheets("Voorraadverloop").Range("A1:IV65536")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
[COLOR="Red"]                LR = Worksheets("Voorraadverloop").Cells(Rows.Count, 1).End(xlUp).Row + 2
     With Sheets("Inkoopscherm")
    .Cells(LR, 1) = Sheets("Voorraadscherm").Cells(4, 1)
    .Cells(LR, 3) = Sheets("Voorraadscherm").Cells(4, 3)
    .Cells(LR, 5) = Sheets("Voorraadscherm").Cells(4, 5)[/COLOR]
End With
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

Deze code vind de zoekopdracht in een gewenste sheet. Het enige wat nog niet lukt is de code plakken in dit scherm (in de code aangegeven met rode kleur). Dit komt omdat het laatste gedeelte van dit stuk code de rode kleur afhankelijk is van het product.
.Cells(LR, 1) = Sheets("Voorraadscherm").Cells(4, 1)
.Cells(LR, 3) = Sheets("Voorraadscherm").Cells(4, 3)
.Cells(LR, 5) = Sheets("Voorraadscherm").Cells(4, 5)

Ikzelf zit te denken aan een oplossing met een offset, maar weet niet precies hoe ik dit moet implementeren. Hebben jullie enig idee? Mochten jullie een ander idee hebben, is dit ook welkom uiteraard.

Deze code wil ik ook toepassen op het aanpassen op het werkelijk aantal in voorraad (voorraadscherm cel J29 en lager). De code die ziet er tot nu toe als volgt uit:

Code:

Private Sub NieuweVoorraad()
    Dim FindString As String
    Dim Rng As Range
    FindString = Range("A21")
    If Trim(FindString) <> "" Then
        With Sheets("Voorraadscherm").Range("A29:A65536")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
    ActiveCell.Offset(0, 9).Select
[COLOR="Red"]    ActiveCell – Range("A21").Value[/COLOR]
End With
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
    Sheets("Voorraadscherm").Range("A21").ClearContents
    Sheets("Voorraadscherm").Range("C21").ClearContents
End Sub

Dit gegeven geeft een fout. Is er een manier om dit in andere woorden te programmeren?

Ik zou graag het bestand uploaden, maar daar is het te groot voor helaas. Ik kan het wel mailen naar de liefhebber.

Alvast bedankt :thumb:

Wigi · 20 mei 2008

barbaar zei:
Ik zou graag het bestand uploaden, maar daar is het te groot voor helaas. Ik kan het wel mailen naar de liefhebber.

Neen dank u, maar maak er een klein voorbeeldbestandje van en je zal veel eerder een antwoord krijgen. Enkel de basics, geen opmaak, niet veel tekst, ...

Hoornvan · 21 mei 2008

Hallo barbaar,

Ik weet er niet veel van maar de macro van het distributiescherm is die niet te lang?
Het zou mooi zijn als deze net zo werkte als de invoerknop (1 regel tegelijk).
Nu heb je 20 regels met 20 variablelen en krijg je dus 20 x de code.
Als je dat korter maakt b.v.b. 10 regels wordt het dan nog te lang?

Roncancio · 21 mei 2008

Het groeien van het bestand zou er niet toe moeten leiden dat de macro ook (evenredig) groeit.
Je zou meer gebruik moeten maken van lussen.

Dus ipv.:

Code:

With Sheets("Distributie historie")
    .Cells(LR, 1) = Sheets("Distributiescherm").Cells(4, 1)
    .Cells(LR, 2) = Sheets("Distributiescherm").Cells(4, 2)
    .Cells(LR, 3) = Sheets("Distributiescherm").Cells(4, 3)
    .Cells(LR, 4) = Sheets("Distributiescherm").Cells(4, 4)
    .Cells(LR, 5) = Sheets("Distributiescherm").Cells(4, 5)
    .Cells(LR, 6) = Sheets("Distributiescherm").Cells(4, 6)
    .Cells(LR, 7) = Sheets("Distributiescherm").Cells(4, 7)
    .Cells(LR, 8) = Sheets("Distributiescherm").Cells(4, 8)
End With

Wordt het dan:

Code:

For iKol = 1 to 8
      Sheets("Distributie historie").Cells(LR, iKol) = Sheets("Distributiescherm").Cells(4, iKol)
Next

Zoals je ziet veel korter en makkelijker te onderhouden.
Worden er namelijk kolommen toegevoegd dan hoef je uitsluitend de 8 aan te passen.

Met vriendelijke groet,

Roncancio

barbaar · 21 mei 2008

Wigi,

Ik heb geprobeerd het bestandje te verkleinen, maar dit is gewoonweg niet mogelijk omdat het probleem wat zich voordoet afhangt van meerdere sheets waarvan de data niet zomaar verwijderd kan worden.

Hoornvan,

De macro van het distributiescherm is ook te lang, wil deze ook nog aanpassen. Ik kan deze helaas niet verkleinen, aangezien ik later er vanuit ga dat ik alle 20 regels nodig zou kunnen hebben.

Roncancio,

Ik ga het eens implementeren, bedankt

Dit scheelt al een hele hoop. Ik ben echter bang dat als er straks veel meer producten zijn, dat de procedure nog te groot blijft in andere delen van het bestand. Vandaar dat ik eigenlijk ook het probleem wat ik in mijn vorige post heb geplakt werkend krijg. Heb jij (of iemand anders) ook een oplossing op?

:thumb:

barbaar · 21 mei 2008

Even een kleine update. Ik heb inmiddels de code van het vinden aangepast.

Deze is nu als volgt:

Code:

Sub PlaatsingVoorraadverloop() 
    Dim FindString As String 
    Dim Rng As Range 
    Dim Lr As Long 
    FindString = Range("A21") 
    If Trim(FindString) <> "" Then 
        With Sheets("Voorraadverloop").Range("A1:IV65536") 
            Set Rng = .Find(What:=FindString, _ 
            After:=.Cells(.Cells.Count), _ 
            LookIn:=xlValues, _ 
            LookAt:=xlWhole, _ 
            SearchOrder:=xlByRows, _ 
            SearchDirection:=xlNext, _ 
            MatchCase:=False) 
            If Not Rng Is Nothing Then 
                Application.Goto Rng, True 
                Lr = Worksheets("Voorraadverloop").ActiveCell.End(xlDown).Row + 2 
                With Sheets("Voorraadverloop") 
                    .Cells(Lr, 1) = Sheets("Voorraadscherm").Cells(21, 1) 
                    .Cells(Lr, 3) = Sheets("Voorraadscherm").Cells(21, 3) 
                    .Cells(Lr, 5) = Sheets("Voorraadscherm").Cells(21, 5) 
                End With 
            Else 
                 MsgBox "Nothing found" 
            End If 
        End With 
    End If 
End Sub

Een voorbeeldje van hoe het moet werken:

De macro loopt bij de voglende regel vast:

Code:

                Lr = Worksheets("Voorraadverloop").ActiveCell.End(xlDown).Row + 2 
                With Sheets("Voorraadverloop")

De fout die ik krijg is:

Fout 438 tijdens uitvoering: Deze eigenschap wordt niet ondersteund door dit project

Als ik xlDown verander in xlUp, dan werkt de macro wel, maar doet het niet wat ik wil, aangezien ik de gegevens onder het productnummer wil hebben staan.

Roncancio · 21 mei 2008

Je kunt beter geen GoTo gebruiken.
Vervang:

Code:

 If Not Rng Is Nothing Then 
                Application.Goto Rng, True 
                Lr = Worksheets("Voorraadverloop").ActiveCell.End(xlDown).Row + 2 
                With Sheets("Voorraadverloop") 
                    .Cells(Lr, 1) = Sheets("Voorraadscherm").Cells(21, 1) 
                    .Cells(Lr, 3) = Sheets("Voorraadscherm").Cells(21, 3) 
                    .Cells(Lr, 5) = Sheets("Voorraadscherm").Cells(21, 5) 
                End With 
            Else 
                 MsgBox "Nothing found" 
            End If

Door:

Code:

           If Not Rng Is Nothing Then 
                If Worksheets("Voorraadverloop").Range("A6").Value ="" then
                    Lr=6
                Else
                     Lr = Worksheets("Voorraadverloop").Range("A5").End(xlDown).Row + 1 
                 End If
                With Sheets("Voorraadverloop") 
                    .Cells(Lr, "A") = Sheets("Voorraadscherm").Cells(21, "A") 
                    .Cells(Lr, "C") = Sheets("Voorraadscherm").Cells(21, "C") 
                    .Cells(Lr, "E") = Sheets("Voorraadscherm").Cells(21, "E") 
                End With 
            Else 
                 MsgBox "Nothing found" 
            End If

Met vriendelijke groet,

Roncancio

barbaar · 22 mei 2008

ok vervangen

is het ook mogelijk om een variabele in te vullen in het rode gedeelte van onderstaande code en zo ja, hoe?

Code:

                    .[COLOR="Red"]Cells(Lr, "A") [/COLOR]= Sheets("Voorraadscherm").Cells(21, "A") 
                    [COLOR="red"].Cells(Lr, "C") = [/COLOR]Sheets("Voorraadscherm").Cells(21, "C") 
                    [COLOR="red"].Cells(Lr, "E") = [/COLOR]Sheets("Voorraadscherm").Cells(21, "E")

De variabele moet er voor zorgen dat de gegevens in de kolom onder het bijbehorende productnummer worden geplaatst.

Roncancio · 22 mei 2008

barbaar zei:
ok vervangen

is het ook mogelijk om een variabele in te vullen in het rode gedeelte van onderstaande code en zo ja, hoe?

Code:

.[COLOR="Red"]Cells(Lr, "A") [/COLOR]= Sheets("Voorraadscherm").Cells(21, "A") [COLOR="red"].Cells(Lr, "C") = [/COLOR]Sheets("Voorraadscherm").Cells(21, "C") [COLOR="red"].Cells(Lr, "E") = [/COLOR]Sheets("Voorraadscherm").Cells(21, "E")

De variabele moet er voor zorgen dat de gegevens in de kolom onder het bijbehorende productnummer worden geplaatst.

Hoe bedoel je precies?
Door de code..

Code:

               If Worksheets("Voorraadverloop").Range("A6").Value ="" then
                    Lr=6
                Else
                     Lr = Worksheets("Voorraadverloop").Range("A5").End(xlDown).Row + 1 
                 End If

... krijgt Lr de rijnummer van het eerstvolgende lege cel in de A-kolom.

Met vriendelijke groet,

Roncancio

barbaar · 22 mei 2008

Roncancio zei:
Hoe bedoel je precies?
Door de code..

Code:

If Worksheets("Voorraadverloop").Range("A6").Value ="" then Lr=6 Else Lr = Worksheets("Voorraadverloop").Range("A5").End(xlDown).Row + 1 End If

... krijgt Lr de rijnummer van het eerstvolgende lege cel in de A-kolom.

Met vriendelijke groet,

Roncancio

Hoi Roncanio, ik snap wat je bedoelt, ik denk dat ik het niet goed genoeg heb uitgelegd. Ik hoop dat ik het nu wat duidelijker kan maken.

De gegevens van cel A21 C21 en E21 worden geplaatst in het tabblad "voorraadverloop". Als cel A21 in het tabblad "voorraadscherm" 123 is, moeten de gegevens geplaatst worden onder de laatste 20 handelingen van productnummer 123. Als cel A21 in het tabblad "voorraadscherm" 456 is, moeten de gegevens geplaatst worden onder de laatste 20 handelingen van productnummer 456 enz.

Ik hoop dat het duidelijk is

barbaar · 23 mei 2008

niemand een idee?

Roncancio · 23 mei 2008

barbaar zei:
niemand een idee?

Dat wel, maar ik mij niet in tweeën delen.

Onderstaande code zoekt in voorraadverloop naar de waarde van cel A21 van voorraadscherm.
Vervolgens worden productnummer, aantal en datum in de bijbehorende lijst van voorraadverloop geplaatst.

Code:

Sub Wegschrijven()
Dim iRij, iBR As Integer
    iBR = 23
    With Worksheets("Voorraadverloop").Range("A1:IV10")
        Set P = .Find(Worksheets("Voorraadscherm").Range("A21").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not P Is Nothing Then
            iRij = Worksheets("Voorraadverloop").Cells(P.Row, P.Column).End(xlDown).Row + 1
            While Worksheets("Voorraadscherm").Cells(iBR, "A").Value <> ""
                Worksheets("Voorraadverloop").Cells(iRij, P.Column).Value = Worksheets("Voorraadscherm").Range("A" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 2).Value = Worksheets("Voorraadscherm").Range("C" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 4).Value = Worksheets("Voorraadscherm").Range("E" & iBR).Value
                iBR = iBR + 1
                iRij = iRij + 1
            Wend
        End If
    End With
End Sub

Met vriendelijke groet,

Roncancio

barbaar · 23 mei 2008

Roncancio zei:

Dat wel, maar ik mij niet in tweeën delen.

Onderstaande code zoekt in voorraadverloop naar de waarde van cel A21 van voorraadscherm.
Vervolgens worden productnummer, aantal en datum in de bijbehorende lijst van voorraadverloop geplaatst.

Code:

Sub Wegschrijven()
Dim iRij, iBR As Integer
    iBR = 23
    With Worksheets("Voorraadverloop").Range("A1:IV10")
        Set P = .Find(Worksheets("Voorraadscherm").Range("A21").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not P Is Nothing Then
            iRij = Worksheets("Voorraadverloop").Cells(P.Row, P.Column).End(xlDown).Row + 1
            While Worksheets("Voorraadscherm").Cells(iBR, "A").Value <> ""
                Worksheets("Voorraadverloop").Cells(iRij, P.Column).Value = Worksheets("Voorraadscherm").Range("A" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 2).Value = Worksheets("Voorraadscherm").Range("C" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 4).Value = Worksheets("Voorraadscherm").Range("E" & iBR).Value
                iBR = iBR + 1
                iRij = iRij + 1
            Wend
        End If
    End With
End Sub

Met vriendelijke groet,

Roncancio

haha dat is zo

Ik ga eens even kijken naar jouw stukje code, feedback komt straks

procedure te groot

Gebruiker

Meubilair

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Inventaris

Gebruiker

Inventaris

Terugkerende gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Gebruiker

Wij waarderen jouw privacy