macro sneller laten werken

Status
Niet open voor verdere reacties.
T

tristi

Gebruiker
Lid geworden
20 nov 2012
Berichten
59
Beste forumleden,

Graag zou ik op jullie kennis beroep willen doen om mijn macro sneller te laten werken (draait nu ongeveer 2 minuten).

De macro werd door mij opgemaakt via opnames en macro's die ik op het forum heb gevonden en zo tot een geheel heb omgevormd.
De macro loopt perfect alleen traag.

Code: 
'Sub cleaning()
Application.ScreenUpdating = False
'
' cleaning Macro
'

'
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    Sheets("cleaning").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.UnMerge
    ActiveWindow.SmallScroll Down:=1
    ActiveWindow.ScrollRow = 5
    ActiveWindow.ScrollRow = 1
    Columns("D:J").Select
    Selection.ColumnWidth = 6
    Columns("K:AE").Select
    Selection.ColumnWidth = 5
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Range("D9:I232").Select
    Dim C As Range, T As String, T2 As Integer, T3 As Integer
    On Error Resume Next
    Range("B9:AE800").Select
    For Each C In Selection
        C.Replace _
            What:=Chr(160), _
            Replacement:=Chr(32)
        'vaste spaties omzetten in spaties
        T = Trim(C.Value)
        With Application.WorksheetFunction
            T2 = .Find(".", T)
            T3 = .Find(".", T, T2 + 1)
        End With
        If IsEmpty(C) Then
        'overslaan lege cellen
        ElseIf LCase(C.Value) Like "*[a-z]*" Then
        'overslaan cellen met letters
        ElseIf C.Value Like "*[@$#;:/\]*" Then
        'overslaan tekens
        ElseIf T3 - T2 = 2 Or T3 - T2 = 3 Then
        'twee punten in een getal overslaan
        Else
            If C.Value Like "*.*" Then
                C.Replace _
                    What:=".", _
                    Replacement:=""
            End If
            
            If IsNumeric(C) Then
            'datum getallen negeren
                C.NumberFormat = "general"
                'celopmaak instellen
                C.Value = C.Value * 1
            End If
        
        End If
    Next
    On Error GoTo 0
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("I1").Select
    Selection.Copy
    Range("D9:I700").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "[h]:mm"
    ActiveWindow.SmallScroll Down:=-15
    Range("C8").Select
    With Sheets("Cleaning")
         For i = 700 To 8 Step -1
         If .Cells(i, 3).Value = "" Then .Cells(i, 3).EntireRow.Delete
      Next
  End With
    With Sheets("Cleaning")
         For i = 700 To 8 Step -1
         If .Cells(i, 11).Value = "" Then .Cells(i, 11).EntireRow.Delete
      Next
  End With
     Range("B8:AA700").Select
     With Selection.Font
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("F11").Select
    Columns("B:B").ColumnWidth = 9
    Range("B2:K2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("D3:I3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J3:AA3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("D4:I4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J4:R4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("S4:AA4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Selection.Copy
    Sheets("input").Select
    Cells.Select
    ActiveSheet.Paste
    Sheets("data").Select
    Range("A2:A700").Select
    Selection.Copy
    Sheets("werkblad").Select
    Range("B14").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("C14").Select
    Sheets("startpagina").Select
    Range("Z1").Select
    Application.ScreenUpdating = True
End Sub

ALvast bedankt !!!!

met vriendelijke groet,

Ria
 
Laatst bewerkt door een moderator:
Begin eerst eens met de macro netjes op te maken met de CODE knop; dit is onleesbaar.
 
Michel,

Sorry, ben hiermee niet echt vertrouwd maar nu toch gelukt.

Nogmaals mijn verontschuldigingen !!!!


Code: 
Sub cleaning()
Application.ScreenUpdating = False
'
' cleaning Macro
'

'
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    Sheets("cleaning").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.UnMerge
    ActiveWindow.SmallScroll Down:=1
    ActiveWindow.ScrollRow = 5
    ActiveWindow.ScrollRow = 1
    Columns("D:J").Select
    Selection.ColumnWidth = 6
    Columns("K:AE").Select
    Selection.ColumnWidth = 5
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:M").Select
    Selection.Delete Shift:=xlToLeft
    Range("D9:I232").Select
    Dim C As Range, T As String, T2 As Integer, T3 As Integer
    On Error Resume Next
    Range("B9:AE800").Select
    For Each C In Selection
        C.Replace _
            What:=Chr(160), _
            Replacement:=Chr(32)
        'vaste spaties omzetten in spaties
        T = Trim(C.Value)
        With Application.WorksheetFunction
            T2 = .Find(".", T)
            T3 = .Find(".", T, T2 + 1)
        End With
        If IsEmpty(C) Then
        'overslaan lege cellen
        ElseIf LCase(C.Value) Like "*[a-z]*" Then
        'overslaan cellen met letters
        ElseIf C.Value Like "*[@$#;:/\]*" Then
        'overslaan tekens
        ElseIf T3 - T2 = 2 Or T3 - T2 = 3 Then
        'twee punten in een getal overslaan
        Else
            If C.Value Like "*.*" Then
                C.Replace _
                    What:=".", _
                    Replacement:=""
            End If
            
            If IsNumeric(C) Then
            'datum getallen negeren
                C.NumberFormat = "general"
                'celopmaak instellen
                C.Value = C.Value * 1
            End If
        
        End If
    Next
    On Error GoTo 0
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("I1").Select
    Selection.Copy
    Range("D9:I700").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "[h]:mm"
    ActiveWindow.SmallScroll Down:=-15
    Range("C8").Select
    With Sheets("Cleaning")
         For i = 700 To 8 Step -1
         If .Cells(i, 3).Value = "" Then .Cells(i, 3).EntireRow.Delete
      Next
  End With
    With Sheets("Cleaning")
         For i = 700 To 8 Step -1
         If .Cells(i, 11).Value = "" Then .Cells(i, 11).EntireRow.Delete
      Next
  End With
     Range("B8:AA700").Select
     With Selection.Font
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("F11").Select
    Columns("B:B").ColumnWidth = 9
    Range("B2:K2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("D3:I3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J3:AA3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("D4:I4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J4:R4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("S4:AA4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Selection.Copy
    Sheets("input").Select
    Cells.Select
    ActiveSheet.Paste
    Sheets("data").Select
    Range("A2:A700").Select
    Selection.Copy
    Sheets("werkblad").Select
    Range("B14").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("C14").Select
    Sheets("startpagina").Select
    Range("Z1").Select
    Application.ScreenUpdating = True
End Sub
 
Een van de redenen dat je macro zo sloom is, ligt in het feit dat je continue Select toepast. Daarmee dwing je Excel om fysiek de cel(len) op te zoeken en te selecteren, wat behoorlijk wat tijd kost. En dat is doorgaans niet nodig; je kunt eigenschappen vanuit elke positie instellen. Dus i.p.v.
Code: 
    Columns("D:J").Select
    Selection.ColumnWidth = 6
    Columns("K:AE").Select
    Selection.ColumnWidth = 5
kan je ook dit doen:
Code: 
    Columns("D:J").ColumnWidth = 6
    Columns("K:AE").ColumnWidth = 5
En
Code: 
     Range("I1").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("I1").Select
    Selection.Copy
    Range("D9:I700").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "[h]:mm"
kan veel sneller zo:
Code: 
    Range("I1").FormulaR1C1 = "1"
    With Range("D9:I700")
        .FormulaR1C1 = 1
        .NumberFormat = "[h]:mm"
    End With
En zo verder. Ik ben geen Excel specialist, en zonder voorbeeldje met gegevens zie ik zo snel niet wat je aan het doen bent, maar overal waar je Select gebruikt kun je dus snelheidswinst boeken.
 
Dag Michel,

Bedankt voor jouw input.
Door deze wijzigingen loopt de maro al 30 seconden sneller maar toch nog altijd 1min30, wat nog steeds langzaam is.
Het is inderdaad moeilijk raad te geven indien je geen zicht op het bestand waarvoor deze macro dient.
Het betreft hier een gegenereede xl file van een PDF bestand.
De macro heeft tot doel om dit bestand te cleanen en om te zetten in getallen (nu zijn dit allemaal tekst gegevens) zodat ik met deze gegevens allerlei berekeningen kan doen.
Het tool zelf is bijna 1MB zodat dit zelfs met een zipfile nog te groot is om hier toe te voegen.

Hopend op toch nog een hint of een beetje hulp dierbij de aangepaste macro.

Alvast bedankt !!!

Code: 
Sub cleaning()
Application.ScreenUpdating = False
'
' cleaning Macro
'

'
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    Sheets("cleaning").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.UnMerge
    ActiveWindow.SmallScroll Down:=1
    ActiveWindow.ScrollRow = 5
    ActiveWindow.ScrollRow = 1
    Columns("D:J").ColumnWidth = 6
    Columns("K:AE").ColumnWidth = 5
    Columns("H:H").Delete Shift:=xlToLeft
    Columns("K:K").Delete Shift:=xlToLeft
    Columns("L:M").Delete Shift:=xlToLeft
    Range("D9:I232").Select
    Dim C As Range, T As String, T2 As Integer, T3 As Integer
    On Error Resume Next
    Range("B9:AE800").Select
    For Each C In Selection
        C.Replace _
            What:=Chr(160), _
            Replacement:=Chr(32)
        'vaste spaties omzetten in spaties
        T = Trim(C.Value)
        With Application.WorksheetFunction
            T2 = .Find(".", T)
            T3 = .Find(".", T, T2 + 1)
        End With
        If IsEmpty(C) Then
        'overslaan lege cellen
        ElseIf LCase(C.Value) Like "*[a-z]*" Then
        'overslaan cellen met letters
        ElseIf C.Value Like "*[@$#;:/\]*" Then
        'overslaan tekens
        ElseIf T3 - T2 = 2 Or T3 - T2 = 3 Then
        'twee punten in een getal overslaan
        Else
            If C.Value Like "*.*" Then
                C.Replace _
                    What:=".", _
                    Replacement:=""
            End If
            
            If IsNumeric(C) Then
            'datum getallen negeren
                C.NumberFormat = "general"
                'celopmaak instellen
                C.Value = C.Value * 1
            End If
        
        End If
    Next
    On Error GoTo 0
    Range("I1").FormulaR1C1 = "1"
     With Range("D9:I700")
        .FormulaR1C1 = 1
        .NumberFormat = "[h]:mm"
    End With
    Range("C8").Select
    With Sheets("Cleaning")
         For i = 700 To 8 Step -1
         If .Cells(i, 3).Value = "" Then .Cells(i, 3).EntireRow.Delete
      Next
  End With
    With Sheets("Cleaning")
         For i = 700 To 8 Step -1
         If .Cells(i, 11).Value = "" Then .Cells(i, 11).EntireRow.Delete
      Next
  End With
     Range("B8:AA700").Select
     With Selection.Font
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("F11").Select
    Columns("B:B").ColumnWidth = 9
    Range("B2:K2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("D3:I3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J3:AA3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("D4:I4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("J4:R4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Range("S4:AA4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Selection.Copy
    Sheets("input").Select
    Cells.Select
    ActiveSheet.Paste
    Sheets("data").Select
    Range("A2:A700").Select
    Selection.Copy
    Sheets("werkblad").Select
    Range("B14").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("C14").Select
    Sheets("startpagina").Select
    Range("Z1").Select
    Application.ScreenUpdating = True
End Sub
 
gebruik bijv.

Code: 
Range("B9:AE800").replace chr(160)," "
en bijv.
Code: 
columns(3).specialcells(4).entirerow.delete

Al die lussen maken de zaak onnodig traag.
Kijk per ongeluk ook eens in je VBA handboek.


Het lijkt erop dat je een 'vuil' plat ascii bestand in Excel hebt geïmporteerd.
Je kunt beter eerst een ascii bestand 'schonen' voordat je het in Excel opneemt.
Aciii bewerkingen gaan veel sneller dan Excel-bewerkingen.

Plaats svp hier eerst een voorbeeld van het ongeschoonde ascii bestand.
 
Dag SNB,

Bedankt voor u reactie en uw terechte opmerkingen.
Het betreft hier inderdaad een vervuilde Ascii bestand. Doch dit is wat mijn collega's en ik maandelijks ter beschikking worden gesteld.
De bijlage bestaat uit 4 blz doch in werkelijkheid zijn er dat 25 tot 30 blz. Hiermee dienen wij een exelbestand op te maken met een aparte sheet voor alle teamleaders waarop enkel de gegevens van hun eigen teamleden op vermeld staan.

Gezien vele van mijn collega's niet echt thuis zijn in exel heb ik dan een tool opgemaakt waarin zij enkel nog hun databetand en de maandelijkse download dienen in te voegen en via de macro's wordt dan alles netjes opgekuist en per teamleader een sheet aangemaakt waarmee deze dan zelf aan de slag kunnen gaan qua berekeningen, rangschikkingen enz.

De macro (zelf opname + macro's die ik op het forum heb gevonden en aangepast) doet het uitstekend alleen heel traag.

Ik ben als leek 6 maanden terug hier op het forum terecht gekomen en heb hier al veel geleerd en gelezen en ben wel onder de indruk gekomen van enkele personen die hulp bieden aan de vele problemen. Uw tussenkomsten worden heel hoog gewardeerd en worden door mij veel gelezen en gevolgd :-)

Ik u alvast bedanken met of zonder oplossing!!!!!

Bekijk bijlage help mij.xls
 
Ik denk dat hiermee 99% geklaard wordt:

Code: 
Sub M_snb()
    Sheets(1).UsedRange.Value = Sheets(1).UsedRange.Value
End Sub
 
Beste SNB en Michel,

Gelieve mij te willen verontschuldigen voor deze late reactie.
Familiale problemen (overlijden) hebben nu prioriteit.

Volgende week ga ik terug aan het werk en zal dan nog eens mijn exel probleem onder handen nemen.

Alvast bedankt voor jullie hulp maar ik denk dat ik toch nog zal terug komen op het probleem.

Vriendelijke groet,

Ria
 
Beste SNB,

Ik heb de macro om het gedownload exel bestand te zuiveren in mijn eigen macro geplaatst en het gedeelte waarin alle gegevens in getallen werd omgezet verwijderd.

Want is inderdaad dit gedeelte dat door de vele loops de macro zo traag maakte.
Het resultaat is gewoon schitterend. wanneer ik eerst de macro liet lopen was de duur ervan 1 minuut 30.
Nu na de gedane aanpassingen duurt hij nog slechts 6 seconden.

Dit had ik nooit alleen kunnen bewerkstellen.

Bedankt SNB voor deze prachtige oplossing ook Michel wil ik danken voor zijn inbreng.
Ik ben en zal zeker een trouwe forum bezoeker blijven want hier is voor mij nog echt veel te leren.

Met vriendelijke groet,

Ria
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan