macro sneller maken

[markdehaan]

Hallo allemaal,
ik weet dat er over dit onderwerp al heel wat vragen zijn gesteld, maar ik kom er toch niet uit.
Ik heb een macro gemaakt die een database omzet naar statestieken, alleen doet hij er nogal lang over om het te berekenen. Ik weet haast wel zeker dat ik nogal omslachtig te werk ga aangezien mijn kennis van VBA niet optimaal is. De rijen waar de macro op draait staan vol met 0en en 1tjes dit zodat ik ze op kan tellen.

De code ziet er als volgt uit:

Selection.AutoFilter Field:=33, Criteria1:="1"
Application.Run "opzet.xls!macro12"

Range("c1").Select
    Selection.Copy
    Sheets("maandoverzicht").Select
    Range("c18").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("macro").Select
Range("A1").Select
    Selection.Copy
    Sheets("maandoverzicht").Select
    Range("C19").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("macro").Select
    Range("B1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("maandoverzicht").Select
    Range("C20").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 Sheets("macro").Select
    Range("k1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("maandoverzicht").Select
    Range("c21").Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("data").Select
Selection.AutoFilter Field:=33

En dat dan voor een stuk of 20 verschillende rijen

De macro die jullie er tussen zien staan is trouwens:

Sub Macro12()

Range("ad3:ad1500").Select
Selection.Copy
Sheets("macro").Select
Range("a2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Data").Select
Range("ae3:ae1500").Select
Selection.Copy
Sheets("macro").Select
Range("b2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Sheets("data").Select
Range("ac3:ac1500").Select
Selection.Copy
Sheets("macro").Select
Range("c2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("data").Select
    Range("at3:at1343").Select
    Selection.Copy
    Sheets("macro").Select
    Range("k2").Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
End Sub

Deze macro kopieerd de waarden naar a2 dit doet hij omdat ik de som van de waarden wil hebben. in a1 staat dus som(a:a) deze kopieerd hij dan met de eerste macro weer weg naar het uiteindelijke blad waar het in een tabel komt te staan.

Het is nogal een lang verhaal geworden, maar ik hoop dat er iemand is die het begrijpt en me een snellere/kortere code kan uitleggen.

alvast bedankt!

mark

 

[mcs51mc]

Misschien moet je een object declareren voor beide sheets "macro" en "maandoverzicht" Op die manier worden 6 lijnen in jouw macro 1 lijn
Merk op dat de namen van de sheets nog moeten aangepast worden.

Private Sub trial()
Dim objBronSheet    As Worksheet
Dim objDoelSheet    As Worksheet

    Application.ScreenUpdating = False
    
    Set objBronSheet = ActiveWorkbook.Sheets("Blad1")
    Set objDoelSheet = ActiveWorkbook.Sheets("maandoverzicht")
    
    'Range("c1").Select
    'Selection.Copy
    'Sheets("maandoverzicht").Select
    'Range("c18").Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    objDoelSheet.Range("C18") = objBronSheet.Range("C1")
    
    
    'Sheets("macro").Select
    'Range("A1").Select
    'Selection.Copy
    'Sheets("maandoverzicht").Select
    'Range("C19").Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    objDoelSheet.Range("C19") = objBronSheet.Range("A1")
    
    
    'Hier kan je alle andere copy opdrachten zetten
    
    Application.ScreenUpdating = True

    'Verwijderen referentie
    Set objBronSheet = Nothing
    Set objDoelSheet = Nothing
    

End Sub

Verder zeg je ook dat je de som van een aantal cellen moet hebben, waarom geen gebruik maken van de "Sum" worksheetfunction??
Je moet dan niets kopiëren, enkel de range toewijzen.

Private Sub trial_2()
Dim rngMyRange  As Range
Dim dblSum      As Double

    'een range object declareren
    Set rngMyRange = ActiveSheet.Range("k1:k1500")
    
    'de som maken van de range in een variabele
    dblSum = Application.WorksheetFunction.Sum(rngMyRange)
    Debug.Print dblSum
    
    'de som maken van de range in een cel zetten
    ActiveSheet.Range("A1").Value = Application.WorksheetFunction.Sum(rngMyRange)
    
    'Verwijderen referentie
    Set rngMyRange = Nothing
    
End Sub

Hopelijk heb je hier iets aan... ... ...

 

[markdehaan]

Bedankt!
Ik kan de macro nu al fors inkorten!
De andere code die je geeft werk niet, omdat hij dan de hele kolom bij elkaar opteld en niet alleen degene die zichbaar zijn na het filter.

mark

 

[mcs51mc]

Bedankt!
De andere code die je geeft werk niet, omdat hij dan de hele kolom bij elkaar opteld en niet alleen degene die zichbaar zijn na het filter.

Die code werkt wel, echter hij doet niet wat jij verwacht
Kleine nuance die we als volgt oplossen

Private Sub trial_2()
Dim rngMyRange  As Range
Dim dblSum      As Double

    'een range object declareren
    Set rngMyRange = ActiveSheet.Range("k1:k1500")[B].SpecialCells(xlCellTypeVisible)[/B]
    
    
    'de som maken van de range in een variabele
    dblSum = Application.WorksheetFunction.Sum(rngMyRange)
    Debug.Print dblSum
    
    'de som maken van de range in een cel zetten
    ActiveSheet.Range("A1").Value = Application.WorksheetFunction.Sum(rngMyRange)
    
    'Verwijderen referentie
    Set rngMyRange = Nothing
    
End Sub

 

[markdehaan]

Bedankt!
Nu werkt het perfect