• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA optimaliseren

Status
Niet open voor verdere reacties.
J

jamstar

Gebruiker
Lid geworden
16 dec 2015
Berichten
39
Goedeavond,

Mij VBA is nogal traag, de code is nogal lang. We ziet er nog verbeterpunten.

Alvast bedankt.


Code: 
Public Which As String
Public Choice As Boolean
Public VensterOffset As Integer

Sub Menu()
    Which = True
    Choice = False
    With UserForm1
        For i = 1 To 150
            .Begin.AddItem (i)
            .Eind.AddItem (i)
        Next
        .KopTekst.Text = Worksheets("project").Cells(6, 2)
        .Projectnaam.Text = Worksheets("project").Cells(1, 2)
        .Projectnummer.Text = Worksheets("project").Cells(2, 2)
        .VoetTekst.Text = Worksheets("project").Cells(10, 2)
        .TopMarge.Text = Worksheets("Project").Cells(23, 2)
        .OnderMarge.Text = Worksheets("Project").Cells(24, 2)
        .LinkerMarge.Text = Worksheets("Project").Cells(25, 2)
        .RechterMarge.Text = Worksheets("Project").Cells(26, 2)
        .LetterGrootte.Text = Worksheets("Project").Cells(27, 2)
        If Worksheets("Project").Cells(30, 2) = 1 Then .EnvLinks = True
        If Worksheets("Project").Cells(30, 2) = 5 Then .EnvRechts = True
        Select Case CInt(Worksheets("project").Cells(29, 2))
        Case 1
            .ConceptFactuur = True
        Case 2
            .DefinitieveFactuur = True
        Case 3
            .MeterkastBrief = True
        Case 4
        .Prijzenboek = True
        Case 5
        .INSTALLAIEPERBOUWNUMMER = True
         Case 6
        .analyse = True
         Case Else
        End Select
        .Show
    End With
    'DialogSheets("dialog1").OptionButtons("Option Button 9").Value = xlOn
    'DialogSheets("dialog1").Show
    Dim vanaf As Integer
    Dim tot As Integer
    If Choice = True Then
        vanaf = CDbl(Worksheets("namen").Cells(60000, 1))
        tot = CDbl(Worksheets("namen").Cells(60001, 1))
        Dim n As Integer
        For n = vanaf To tot
            gaan2 (n)
        Next
    End If
End Sub

Sub gaan2(ByVal bouwnummer As Integer)
    Dim naamr, pR, pC, NR, invoerR, invoerC As Integer
    Dim offsetr As Integer
    Dim offsetC As Integer
    Dim TotaalMemi As Double
    offsetr = 19
    offsetC = 1
    Select Case c
    Case c = 0
    pR = r
    Case Else
        NR = setR(bouwnummer)
        pC = setC(bouwnummer)
        naamr = setR(bouwnummer)
        If naamr <> 0 Then
            Call putName(naamr)
            With Worksheets("invoer")
                invoerR = 3
                invoerC = setC(bouwnummer)
                If invoerC <> 0 Then
                    Sheets("Uitvoer").Range("Uitvoer").ClearContents
                    Sheets("Uitvoer").Range("Uitvoer").Font.Size = Worksheets("Project").Cells(27, 2)
                    Sheets("Uitvoer").Range("Uitvoer").Font.Bold = False
                    putName naamr
                    PutHeader 17, 1
                    TotaalMemi = 0
                    While .Cells(invoerR, 3).Value <> ""
                        If CDbl(.Cells(invoerR, invoerC)) >= 1 Then
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 3).Value = .Cells(invoerR, 2).Value  'Type/Soort
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 3).Value = .Cells(invoerR, 3).Value  '?
                            If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then

                            End If
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = .Cells(invoerR, invoerC).Value 'Aantal
                            Select Case UCase(Which)
                            Case "CONCEPTFACTUUR"
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'Code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) 'Prijs
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 4).Value  'omschrijving
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 5).Value = .Cells(invoerR, 8).Value 'Prijs
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = CDbl(.Cells(invoerR, 8).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                End If
                             Case "DEFINITIEVEFACTUUR"
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC).Value = .Cells(invoerR, 1).Value      '0 teken
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'Code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) 'Prijs
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC).Value = .Cells(invoerR, 1).Value      '0 teken
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 4).Value  'omschrijving
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = CDbl(.Cells(invoerR, 8).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                End If
                            Case "METERKASTBRIEF"
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'Code
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 5).Value  'omschrijving
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                End If
                            
                            Case "PRIJZENBOEK"
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'Code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) 'Prijs
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 4).Value  'omschrijving
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = CDbl(.Cells(invoerR, 9).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                End If

                            Case "INSTALLATIEPERBOUWNUMMER"
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'Code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) 'Prijs
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 4).Value  'omschrijving
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 5).Value = .Cells(invoerR, 9).Value 'Prijs
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = CDbl(.Cells(invoerR, 9).Value) * CDbl(.Cells(invoerR, invoerC).Value) 'Totaal
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                End If
                            
                             Case "ANALYSE"
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'Code
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 747).Value  'omschrijving
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 2).Value  'code
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 8).Value = .Cells(invoerR, 13).Value  'bouwnr samenvoegen
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = .Cells(invoerR, 14).Value  'aantallen
                                    TotaalMemi = TotaalMemi + Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value
                                End If
                            End Select
                            offsetr = offsetr + 1
                        End If
                        invoerR = invoerR + 1
                    Wend
                    PutFooter offsetr, TotaalMemi, CInt(naamr)
                    
                End If
                
            End With
        End If
    End Select
   Sheets("uitvoer").Select
End Sub
Sub KopVoet(kop As String, voet As String)
    With Worksheets("uitvoer").PageSetup
        .LeftHeader = ""
        'Worksheets("project").Cells(12, 2).Value
        '"" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "Nieuw Vennep, projekt Getsewoud, 30 koopwoningen :" & Chr(10) & "&""Arial,Vet\&20Opdrachtbevestiging"
        .CenterHeader = ""
        .RightHeader = kop
        .LeftFooter = ""
        'Worksheets("project").Cells(11, 2).Value & Chr(10) & Worksheets("project").Cells(12, 2).Value
        '"S.v.p. per omgaande 1 exemplaar voor accoord getekend retourneren." & Chr(10) & "" & Chr(10) & "Bedragen inclusief 17,5 % Btw"
        .CenterFooter = voet
        '.RightFooter = "&8Pagina &P van &N"
        .LeftMargin = Application.CentimetersToPoints(Worksheets("Project").Cells(25, 2))
        .RightMargin = Application.CentimetersToPoints(Worksheets("Project").Cells(26, 2))
        .TopMargin = Application.CentimetersToPoints(Worksheets("Project").Cells(23, 2))
        .BottomMargin = Application.CentimetersToPoints(Worksheets("Project").Cells(24, 2))
        .HeaderMargin = Application.CentimetersToPoints(0.5)
        '.FooterMargin = Application.CentimetersToPoints(0.5)
        '.PrintHeadings = False
        '.PrintGridlines = False
        '.PrintComments = xlPrintNoComments
        '.PrintQuality = 300
        '.CenterHorizontally = False
        '.CenterVertically = False
        '.Orientation = xlPortrait
        '.Draft = False
        .PaperSize = xlPaperA4
        '.FirstPageNumber = xlAutomatic
        '.Order = xlDownThenOver
        '.BlackAndWhite = False
        '.Zoom = False
        '.FitToPagesWide = 1
        '.FitToPagesTall = 1
    End With
    'ActiveWindow.SelectedSheets.PrintPreview
    Worksheets("uitvoer").Rows.AutoFit
End Sub
Sub PutFooter(offsetr As Integer, Totaal As Double, naamr As Integer)
     Select Case UCase(Which)
    Case "CONCEPTFACTUUR"
        Worksheets("Uitvoer").Cells(12, 2).Value = "OPDRACHTBEVESTIGING"
        Worksheets("Uitvoer").Cells(8, 6).Value = ""
        Worksheets("Uitvoer").Cells(8, 7).Value = ""
        Worksheets("Uitvoer").Cells(offsetr + 3, 2).Value = "Totaal Meer en Minderwerk"
        Worksheets("Uitvoer").Cells(offsetr + 6, 2).Value = "Geldigheidsduur: Deze offerte is geldig tot twee weken na de offertedatum."
        Worksheets("Uitvoer").Cells(offsetr + 5, 2).Value = "Betaling meerwerk: Conform koop/aannemingsovereenkomst."
        Worksheets("Uitvoer").Cells(offsetr + 7, 2).Value = "S.v.p. per omgaande 1 exemplaar voor accoord getekend retourneren, per post of per e-mail."
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).Value = Totaal
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).NumberFormat = "€ #,##0.00_-"
        Worksheets("Uitvoer").Cells(offsetr + 9, 2).Value = "Getekend te :"
        Worksheets("Uitvoer").Cells(offsetr + 10, 2).Value = "Datum :"
        Worksheets("Uitvoer").Cells(offsetr + 11, 2).Value = "Voor accoord koper(s) :"
        Worksheets("Uitvoer").Cells(offsetr + 14, 2).Value = Str(Worksheets("namen").Cells(naamr, 1).Value) + " : " + Worksheets("namen").Cells(naamr, 2).Value + " /of " + Worksheets("namen").Cells(naamr, 3).Value
        Call KopVoet(Worksheets("project").Cells(12, 2).Value & "&""Arial,Vet\&20Offerte", Worksheets("project").Cells(10, 2).Value & Chr(10) & Worksheets("project").Cells(11, 2).Value)
    Case "PRIJZENBOEK"
        Worksheets("Uitvoer").Cells(8, 6).Value = ""
        Worksheets("Uitvoer").Cells(8, 7).Value = ""
        Worksheets("Uitvoer").Cells(12, 4).Value = ""
        Worksheets("Uitvoer").Cells(13, 2).Value = ""
        Worksheets("Uitvoer").Cells(13, 4).Value = ""
        Worksheets("Uitvoer").Cells(14, 4).Value = ""
        Worksheets("Uitvoer").Cells(15, 4).Value = ""
        Worksheets("Uitvoer").Cells(7, 2).Value = ""
        Worksheets("Uitvoer").Cells(10, 6).Value = ""
        Worksheets("Uitvoer").Cells(17, 8).Value = "Totaal ex-btw"
        Worksheets("Uitvoer").Cells(12, 2).Value = "PRIJZENBOEK INSTALLATEUR"
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).NumberFormat = "Totaal"
        Call KopVoet(Worksheets("project").Cells(12, 2).Value & vbCrLf & "&""Arial,Vet\&20Opdrachtbevestiging", Worksheets("project").Cells(10, 2).Value & Chr(10) & Worksheets("project").Cells(11, 2).Value)
    Case "DEFINITIEVEFACTUUR"
        Worksheets("Uitvoer").Cells(10, 8).Value = ""
        Worksheets("Uitvoer").Cells(11, 2).Value = "KOPERSKEUZENLIJST BEHORENDE BIJ DE AANNEMINGSOVEREENKOMST"
        Worksheets("Uitvoer").Cells(12, 2).Formula = Format(Date, "dddd dd mmmm yyyy")
        Worksheets("Uitvoer").Cells(9, 4).Value = ""
        Worksheets("Uitvoer").Cells(12, 4).Value = ""
        Worksheets("Uitvoer").Cells(13, 2).Value = ""
        Worksheets("Uitvoer").Cells(13, 4).Value = ""
        Worksheets("Uitvoer").Cells(14, 4).Value = ""
        Worksheets("Uitvoer").Cells(15, 4).Value = ""
        Worksheets("Uitvoer").Cells(14, 2).Value = "Voor bouwnummer      ................................................................................"
        Worksheets("Uitvoer").Cells(15, 2).Value = "Naam                          ................................................................................"
        Worksheets("Uitvoer").Cells(offsetr + 1, 2).Value = "Sluitingsdatum :"
        Worksheets("Uitvoer").Cells(offsetr + 2, 2).Value = "De uiterlijke datum waarop de door u getekende lijst in bezit moet zijn van de aannemersbedrijf Batenburg"
        Worksheets("Uitvoer").Cells(offsetr + 3, 2).Value = "zal worden bekend gemaakt in een informatiefbrief. "
        Worksheets("Uitvoer").Cells(offsetr + 5, 2).Value = "Handleiding :"
        Worksheets("Uitvoer").Cells(offsetr + 6, 2).Value = "Wij verzoeken u ons uw keuzen kenbaar te maken door de rondjes voor de betreffende onderdelen aan te kruisen."
        Worksheets("Uitvoer").Cells(offsetr + 8, 2).Value = "Bij gemaakte keuzen, verzoeken wij u GEEN opmerkingen, vragen doorhalingen, of iets dergelijks te plaatsen."
        Worksheets("Uitvoer").Cells(offsetr + 9, 2).Value = "Door automatische verwerking worden deze niet gesignaleerd en derhalve niet behandeld."
        Worksheets("Uitvoer").Cells(offsetr + 12, 2).Value = "Getekend te :"
        Worksheets("Uitvoer").Cells(offsetr + 13, 2).Value = "Datum :"
        Worksheets("Uitvoer").Cells(offsetr + 14, 2).Value = "Voor accoord koper(s) :"
        Worksheets("Uitvoer").Cells(8, 6).Value = "Lijstkleur:"
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).NumberFormat = "Totaal"
        Call KopVoet(Worksheets("project").Cells(12, 2).Value & vbCrLf & "&""Arial,Vet\&20Opdrachtbevestiging", Worksheets("project").Cells(10, 2).Value & Chr(10) & Worksheets("project").Cells(11, 2).Value)
    Case "METERKASTBRIEF"
        Worksheets("Uitvoer").Cells(12, 2).Value = "METERKASTLIJST"
        Worksheets("Uitvoer").Cells(8, 6).Value = ""
        Worksheets("Uitvoer").Cells(8, 7).Value = ""
        Call KopVoet(Worksheets("project").Cells(12, 2).Value & vbCrLf & "&""Arial,Vet\&20Meterkastbrief", Worksheets("project").Cells(12, 2).Value & Chr(13) & Worksheets("project").Cells(14, 2).Value)
    Case "INSTALLATIEPERBOUWNUMMER"
        Worksheets("Uitvoer").Cells(12, 2).Value = "INSTALLATIES PER BOUWNUMMER"
        Worksheets("Uitvoer").Cells(8, 6).Value = ""
        Worksheets("Uitvoer").Cells(8, 7).Value = ""
        Worksheets("Uitvoer").Cells(offsetr + 3, 2).Value = "Totaal Meer en Minderwerk voor de installateur"
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).Value = Totaal
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).NumberFormat = "€ #,##0.00_-"
        Worksheets("Uitvoer").Cells(offsetr + 3, 8).Value = Totaal
        Call KopVoet(Worksheets("project").Cells(12, 2).Value & "&""Arial,Vet\&20Offerte", Worksheets("project").Cells(10, 2).Value & Chr(10) & Worksheets("project").Cells(11, 2).Value)
    Case "ANALYSE"
        Worksheets("Uitvoer").Cells(12, 2).Value = "ANALYSE PER OPTIE"
        Worksheets("Uitvoer").Cells(8, 6).Value = ""
        Worksheets("Uitvoer").Cells(8, 7).Value = ""
        Worksheets("Uitvoer").Cells(13, 2).Value = ""
        Worksheets("Uitvoer").Cells(12, 4).Value = ""
        Worksheets("Uitvoer").Cells(13, 4).Value = ""
        Worksheets("Uitvoer").Cells(14, 4).Value = ""
        Worksheets("Uitvoer").Cells(15, 4).Value = ""
        Worksheets("Uitvoer").Cells(17, 6).Value = ""
        Worksheets("Uitvoer").Cells(17, 8).Value = ""
        Worksheets("Uitvoer").Cells(17, 9).Value = "Bouwnummers"
        Case Else
    End Select
    'Using Cell Object
Cells(11, 2).Font.Bold = True
Cells(12, 2).Font.Bold = True
Cells(17, 2).Font.Bold = True
Cells(17, 3).Font.Bold = True
Cells(17, 4).Font.Bold = True
Cells(17, 5).Font.Bold = True
Cells(17, 6).Font.Bold = True
Cells(17, 7).Font.Bold = True
Cells(17, 8).Font.Bold = True
Cells(17, 9).Font.Bold = True

End Sub


Function prijs(ByVal b As Integer, ByVal kode As String) As Double
    With Worksheets("offertes")
        Dim c As Integer
        c = 2
        While .Cells(1, c).Value <> kode
            c = c + 1
        Wend
        If .Cells(b + 1, c).Value = "" Then
            'prijs = "Offerte"
        Else
            prijs = CDbl(.Cells(b + 1, c).Value)
        End If
    End With
End Function
Function datum(ByVal b As Integer, ByVal kode As String) As String
    With Worksheets("offertes")
        Dim c As Integer
        c = 2
        While .Cells(1, c).Value <> kode
            c = c + 1
        Wend
            datum = .Cells(b + 1, c + 1).Value
    End With
End Function
Function sumall(ByVal r As Integer) As Double
Dim sum As Double
    sum = 0
    With Worksheets("uitvoer")
        While r > 1
            If (.Cells(r, 11).Value <> "offerte") And (r <> 17) Then
                sum = sum + CDbl(.Cells(r, 11).Value)
            End If
            r = r - 1
        Wend
    End With
    sumall = sum
End Function
Sub putName(ByVal r As Integer)
    If VensterOffset = 0 Then VensterOffset = 1
    With Worksheets("uitvoer")
            .Cells(12, 4).Value = Worksheets("namen").Cells(r, 2).Value
            .Cells(13, 4).Value = Worksheets("namen").Cells(r, 3).Value
            .Cells(14, 4).Value = Worksheets("namen").Cells(r, 4).Value
            .Cells(15, 4).Value = Worksheets("namen").Cells(r, 5).Value
            .Cells(13, 2).Value = "Bouwnummer " & Worksheets("namen").Cells(r, 1).Value
            .Cells(9, 4).Formula = Format(Date, "dddd dd mmmm yyyy")
      
    End With
End Sub
Function getNR(ByVal r As Integer) As Integer
    getNR = Worksheets("namen").Cells(r, 1)
End Function
Function setC(ByVal NR As Integer) As Integer
    'start NR: (2,12)
    Dim c As Integer
    c = 12
    With Worksheets("invoer")
        While (Val(.Cells(2, c).Value) < NR)
            c = c + 1
        Wend
        If (Val(.Cells(2, c).Value) > NR) Then
            setC = 0
        Else
            setC = c
        End If
    End With
End Function
Function setR(ByVal NR As Integer) As Integer
    'start NR: (1,2)
    Dim naamr As Integer
    naamr = 1
    With Worksheets("namen")
        While (Val(.Cells(naamr, 1).Value) < NR)
            naamr = naamr + 1
        Wend
        If (Val(.Cells(naamr, 1).Value) > NR) Then
            setR = 0
        Else
            setR = naamr
        End If
    End With
End Function
Sub putCodes(ByVal r As Integer, ByVal c As Integer)
    Dim offsetr As Integer
    Dim offsetC As Integer
    offsetr = 22
    offsetC = 1
    With Worksheets("Invoer")
        Worksheets("Uitvoer").Cells(offsetr, offsetC).Value = .Cells(r, 1).Value
        Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(r, 2).Value
        Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(r, 3).Value
        Worksheets("Uitvoer").Cells(offsetr, offsetC + 3).Value = .Cells(r, 4).Value
        Worksheets("Uitvoer").Cells(offsetr, offsetC + 4).Value = .Cells(r, 5).Value
    End With
End Sub

Sub PutHeader(StartRow, StartCol)
    With Worksheets("uitvoer")
        
        .Cells(StartRow, StartCol).Value = ""
        .Cells(StartRow, StartCol + 1).Value = "Code"
        .Cells(StartRow, StartCol + 2).Value = "Omschrijving"
        .Cells(StartRow, StartCol + 3).Value = ""
        .Cells(StartRow, StartCol + 3).Value = "Type"
        .Cells(StartRow, StartCol + 5).Value = ""
        .Cells(StartRow, StartCol + 5).Value = "Prijs"
        .Cells(StartRow, StartCol + 6).Value = "#"
        .Cells(StartRow, StartCol + 7).Value = "Totaal"
    End With
End Sub

Sub gaan(ByVal bouwnummer As Integer)
    Dim naamr, pR, pC, NR, invoerR, invoerC As Integer
    Dim offsetr As Integer
    Dim offsetC As Integer
    offsetr = 19
    offsetC = 3
    Select Case c
    Case c = 0
    pR = r
    Case Else
        NR = setR(bouwnummer)
        pC = setC(bouwnummer)
        naamr = setR(bouwnummer)
        If naamr <> 0 Then
            Call putName(naamr)
            With Worksheets("invoer")
                invoerR = 3
                invoerC = setC(bouwnummer)
                If invoerC <> 0 Then
                    Sheets("Uitvoer").Range("B19:z372").ClearContents
                    Sheets("Uitvoer").Range("B19:z372").Font.Size = 10
                    Sheets("Uitvoer").Range("B19:z372").Font.Bold = False
                  
                    While .Cells(invoerR, 2).Value <> ""
                        If CDbl(.Cells(invoerR, invoerC)) >= 1 Then
                            Worksheets("Uitvoer").Cells(offsetr, offsetC).Value = .Cells(invoerR, 2).Value
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 1).Value = .Cells(invoerR, 3).Value
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 2).Value = .Cells(invoerR, 4).Value
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 3).Value = .Cells(invoerR, 5).Value
                            If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                Worksheets("Uitvoer").Cells(offsetr, offsetC + 5).Value = datum(bouwnummer, .Cells(invoerR, 2).Value)
                            End If
                            If Which = True Then
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                  '  Worksheets("Uitvoer").Cells(offsetR, offsetC + 5).Value = datum(bouwnummer, .Cells(invoerR, 2).Value)
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value)
                                Else
                                   ' Worksheets("Uitvoer").Cells(offsetR, offsetC + 5).Value = datum(bouwnummer, .Cells(invoerR, 2).Value)
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 6).Value = .Cells(invoerR, 8).Value
                                End If
                            End If
                            Worksheets("Uitvoer").Cells(offsetr, offsetC + 7).Value = .Cells(invoerR, invoerC).Value
                         '   Worksheets("Uitvoer").Cells(offsetR, offsetC + 7).Value = CDbl(.Cells(invoerR, 8).Value) * CDbl(.Cells(invoerR, invoerC).Value)
                         '   offsetR = offsetR + 1
                            If Which = True Then
                                If UCase(.Cells(invoerR, 8).Value) = "OFFERTE" Then
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 8).Value = prijs(bouwnummer, .Cells(invoerR, 2).Value) * CDbl(.Cells(invoerR, invoerC).Value)
                                Else
                                    Worksheets("Uitvoer").Cells(offsetr, offsetC + 8).Value = CDbl(.Cells(invoerR, 8).Value) * CDbl(.Cells(invoerR, invoerC).Value)
                                End If
                            End If
                            offsetr = offsetr + 1
                        End If
                        invoerR = invoerR + 1
                    Wend
                    Worksheets("Uitvoer").Cells(offsetr + 3, offsetC + 3).Value = "Totaal Meer en Minderwerk"
                    Worksheets("Uitvoer").Cells(offsetr + 3, offsetC + 8).Value = sumall(offsetr)
                    'Worksheets("Uitvoer").Cells(offsetR + 5, offsetC).Value = "Keuzelijst 1:"
                    'Worksheets("Uitvoer").Cells(offsetR + 6, offsetC).Value = "Keuzelijst 2:"
                    Worksheets("Uitvoer").Cells(offsetr + 5, offsetC + 3).Value = "Keuzelijst 1:  " + Worksheets("namen").Cells(naamr, 8).Value
                    Worksheets("Uitvoer").Cells(offsetr + 6, offsetC + 3).Value = "Keuzelijst 2:  " + Worksheets("namen").Cells(naamr, 9).Value
                    Worksheets("Uitvoer").Cells(offsetr + 9, offsetC + 3).Value = "Getekend te :"
                    Worksheets("Uitvoer").Cells(offsetr + 10, offsetC + 3).Value = "Datum :"
                    Worksheets("Uitvoer").Cells(offsetr + 12, offsetC + 3).Value = "Voor accoord koper(s) :"
                    Worksheets("Uitvoer").Cells(offsetr + 16, offsetC + 3).Value = Str(Worksheets("namen").Cells(naamr, 1).Value) + " : " + Worksheets("namen").Cells(naamr, 2).Value + " /of " + Worksheets("namen").Cells(naamr, 3).Value
                    'Worksheets("Uitvoer").Cells(offsetR + 6, offsetC).Value = Worksheets("namen").Cells(naamr, 3).Value
                    
                    If Worksheets("uitvoer").Cells(19, offsetC) <> "" Then
                        If Which = True Then
                            Call KopVoet(Worksheets("project").Cells(6, 2).Value & Chr(10) & "&""Arial,Vet\&20Opdrachtbevestiging", Worksheets("project").Cells(10, 2).Value & Chr(10) & Worksheets("project").Cells(11, 2).Value)
                        Else
                            Call KopVoet(Worksheets("project").Cells(6, 2).Value & Chr(10) & "&""Arial,Vet\&20Meterkastbrief", "")
                        End If
                        Worksheets("uitvoer").PrintOut 'Copies:=1
                    End If
                End If
            End With
        End If
    End Select
    Sheets("invoer").Select
End Sub
 
Laatst bewerkt:
kijk met timers in de subs waar de vertraging zit.

anders moet je een eventueel verkleind voorbeeld bestand plaatsen.
 
In ieder geval de screen updating uit zetten in de subs die wijzigingen in de cellen aanbrengen.
 
Het is lastig om een voorbeeldbestandje te verzenden, omdat het bestand 13mb is. Zouden jullie kunnen uitleggen wat jullie bedoelen met timers in sub en screen updating uitzetten.

Alvast bedankt voor het meedenken
 
Je kan een Sub beginnen met:
Application.ScreenUpdating = False

En eindigen met:
Application.ScreenUpdating = True

Dat zal al een stuk in snelheid schelen.
 
Beste Edmoor, bedoel je het volgende:



Sub Menu() VERVANGEN DOOR Application.ScreenUpdating = False
Which = True
Choice = False
With UserForm1
For i = 1 To 150
.Begin.AddItem (i)
.Eind.AddItem (i)


Ik ben dat betreft echt een Newbie met VBA, ik kan codes wijzigen maar dan houd mij kennis op.

Bedankt
 
Nee. Dit:
Code: 
Sub Menu()
    Application.ScreenUpdating  = False
    ' Je eigen code
    Application.ScreenUpdating  = True
End Sub
 
Bedankt voor je snelle reactie, ik zal het gelijk uitproberen
 
Het is inderdaad sneller, het schilt circa 5 sec van de 30 sec. Zijn er nog andere oplossing?
 
Heb je dat bij alle Subs gedaan die wijzigingen in de cellen doen?
 
Heb bij alle subs de wijziging toegepast. Zijn er nog andere mogelijkheden?
 
Laatst bewerkt:
Sommige codes zijn zo lang kunnen, zijn deze niet eenvoudiger te maken.


Case "PRIJZENBOEK"
Worksheets("Uitvoer").Cells(8, 6).Value = ""
Worksheets("Uitvoer").Cells(8, 7).Value = ""
Worksheets("Uitvoer").Cells(12, 4).Value = ""
Worksheets("Uitvoer").Cells(13, 2).Value = ""
Worksheets("Uitvoer").Cells(13, 4).Value = ""
Worksheets("Uitvoer").Cells(14, 4).Value = ""
Worksheets("Uitvoer").Cells(15, 4).Value = ""
Worksheets("Uitvoer").Cells(7, 2).Value = ""
Worksheets("Uitvoer").Cells(10, 6).Value = ""
Worksheets("Uitvoer").Cells(17, 8).Value = "Totaal ex-btw"
Worksheets("Uitvoer").Cells(12, 2).Value = "PRIJZENBOEK INSTALLATEUR
 
Zoiets:
Code: 
    With Worksheets("Uitvoer")
        .Cells(8, 6).Value = ""
        .Cells(8, 7).Value = ""
        .Cells(12, 4).Value = ""
        .Cells(13, 2).Value = ""
        .Cells(13, 4).Value = ""
        .Cells(14, 4).Value = ""
        .Cells(15, 4).Value = ""
        .Cells(7, 2).Value = ""
        .Cells(10, 6).Value = ""
        .Cells(17, 8).Value = "Totaal ex-btw"
        .Cells(12, 2).Value = "PRIJZENBOEK INSTALLATEUR "
    End With
 
Als ook:

Code: 
With Worksheets("Uitvoer")
  .Range("F8,G8,D12,B13,D13,D14,D15,B7,F10").ClearContents
  .Cells(17, 8).Value = "Totaal ex-btw"
  .Cells(12, 2).Value = "PRIJZENBOEK INSTALLATEUR "
End With
 
Bedankt voor het meedenken, ik heb alle regels die ik kon wijzigen gewijzigd.Misschien moet ik de snelheid maar accepteren.
 
Bedankt HSV, jouw voorstel werkt goed.

Zou ik onderstaande formule ook kunnen inkorten?
 
Code: 
   'Using Cell Object
Cells(11, 2).Font.Bold = True
Cells(12, 2).Font.Bold = True
Cells(17, 2).Font.Bold = True
Cells(17, 3).Font.Bold = True
Cells(17, 4).Font.Bold = True
Cells(17, 5).Font.Bold = True
Cells(17, 6).Font.Bold = True
Cells(17, 7).Font.Bold = True
Cells(17, 8).Font.Bold = True
Cells(17, 9).Font.Bold = True
 
Uiteraard:

Cellen wel aanpassen.

Code: 
 .Range("F8,G8,D12,B13,D13,D14,D15,B7,F10").font.bold = true
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan