• 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.

Werkbladen vergelijken uitdaging?

Status
Niet open voor verdere reacties.
Warme bakkertje zei:
Al je kolomkoppen kan je in 1 regel plaatsen, dat zijn ook weeral 8 rijen minder.
Code: 
Range("A1").Resize(, 9) = Split("ID|nummer|risico|oorzaak|gevolg|huidige risicoscore|vorige risicoscore|mutatie|maatregelen", "|")
Voor wat betreft het doorvoeren
Code: 
With Range("H2")
        .FormulaR1C1 = _
        "=IF(RC[-1]=0,""nieuw"",IF(RC[-2]=RC[-1],""ongewijzigd"",IF(RC[-2]<RC[-1],""gewijzigd (omlaag)"",IF(RC[-2]>RC[-1],""gewijzigd (omhoog)"",""""))))"
        .AutoFill Destination:=Range("H2:H" & Cells(Rows.Count, [COLOR="red"]1[/COLOR]).End(xlUp).Row), Type:=xlFillDefault
    End With
    With Range("G2")
        .FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-6],Blad2!R2C2:R200C6,5,0)),0,VLOOKUP(RC[-6],Blad2!R2C2:R200C6,5,0))"
        .AutoFill Destination:=Range("G2:G" & Cells(Rows.Count, [COLOR="red"]1[/COLOR]).End(xlUp).Row), Type:=xlFillDefault
    End With
Wijzig de rode 1 in het kolomnummer dat gevuld is met je waarden tot waar je de formule wil doortrekken.
Verder staan er nog een heleboel onnodige Selects in. Het is niet nodig om een object te selecteren om er een bewerking op uit te voeren. Werk dan eerder met With...End with structuren
Als je bij een methode een standaardeigenschap niet wijzigt hoef je ze ook niet te vermelden, dus dit
Code: 
With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Tahoma"
        .FontStyle = "Vet"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
wordt dit
Code: 
With Range("C1").Font
        .Name = "Tahoma"
        .FontStyle = "Vet"
        .Size = 8
    End With
Klik om te vergroten...

Klasse. De eerste en de derde werken.

Maar de tweede niet, of ik snap m niet.

De rode 1 moet het kolomnummer worden dat gevuld is met je waarden tot waar je de formule wil doortrekken.

Ten eerste zie je dat het om kolom H en G gaat, die staat al in de code. En als ik 7 en 8 invul geeft ie een foutmelding.

Als het om rijnummer gaat, is het punt juist dat ik die niet wil geven, maar juist automatisch wil laten doen tot en met de rij waar nog waardes in staan (in bijvoorbeeld kolom A).

Met andere woorden: Als rij 1 tot en met 15 in kolom A een waarde hebben staan, dan moeten cellen H2 en G2 doorgetrokken worden tot en met rij 15, ofwel cel H15 en G15. Als (een andere keer) rij 1 tot en met 34 in kolom A een waarde hebben, moet de cel doorgetrokken worden tot en met rij 34, ofwel cel H34 en cel G34.


Aanvullende vraag: een van de eerste paar stappen is lege rijen verwijderen. Het originele bestand heeft echter samengevoegde cellen, heb tot nu toe altijd eerst alles geselecteerd en vervolgens op samenvoegen geklikt (waardoor het samenvoegen ongedaan werd gemaakt) en vervolgens de macro uitgevoerd. Maar ik heb net vergeten op samenvoegen te klikken en het LIJKT ook te werken. Kan dit? Of doet ie dan iets wat ie niet doeet als ik eerst het samenvoegen ongedaan maak? (overigens klaag ik niet, zou juist ideaal zijn, scheelt mij en mensen na mij, weer een handeling..)
 
Dat bedoel ik dus ook met het nummer wijzigen in het kolomnummer waar je waarden instaan om te berekenen hoever de formules doorgetrokken moeten worden. Staan dus je waarden in kolom A dan laat je de 1 staan, staan je waarden in B zet je hier een 2, enz....
 
Laatst bewerkt:
Warme bakkertje zei:
Dat bedoel ik dus ook met het nummer wijzigen in het kolomnummer waar je waarden instaan om te berekenen hoever de formules doorgetrokken moeten worden. Staan dus je waarden in kolom A dan laat je de 1 staan, staan je waarden in B zet je hier een 2, enz....
Klik om te vergroten...

Te gek! Hij werkt!

en nu... voor finishing touch, de kers op de taart: wil ik onderaan in de macro wat lay-out aanpassen.

- Zelfde als voor het doorvoeren wil ik voor de rijen die een score hebben in kolom A of kolom 1 dus, dat de rijhoogte automatisch wordt aangepast.
 
Laatst bewerkt:
Jonathan1982 zei:
Te gek! Hij werkt!

en nu... voor finishing touch, de kers op de taart: wil ik onderaan in de macro wat lay-out aanpassen.

- Zelfde als voor het doorvoeren wil ik voor de rijen die een score hebben in kolom A of kolom 1 dus, dat de rijhoogte automatisch wordt aangepast.
Klik om te vergroten...

Lijkt het hier op?:

Rows("1:1" & Cells(Rows.Count, 1).End(xlUp).Row).Select
Selection.Rows.AutoFit
 
Code: 
Rows("1:" & Cells(Rows.Count, 1).End(xlUp).Row).RowHeight = 15

Of

Code: 
Rows("1:" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFit
 
Laatst bewerkt:
Te gek! Hij is wat mij betreft AF.

Dit is m nu geworden:

Code: 
Sub Stap1()

    Range("C:C,G:AA,AC:AD").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft

Range("B1").Select

Dim r As Long
Dim C As Range
Dim N As Long
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If
N = 0
For r = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(r).EntireRow) = 0 Then
Rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Copy
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("B:B").Select
    ActiveSheet.Paste

    Range("I13") = "1"
    Range("I13").Copy
    Range("A1:A" & [a1].CurrentRegion.Rows.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
    Range("I13").Copy
    Range("B1:B" & [b1].CurrentRegion.Rows.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
    Range("I13").Copy
    Range("F1:F" & [f1].CurrentRegion.Rows.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False

    Range("I13").ClearContents
    

    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Tahoma"
        .FontStyle = "Vet"
        .Size = 8
    End With

    Columns("A:I").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

With Range("H2")
        .FormulaR1C1 = _
        "=IF(RC[-1]=0,""nieuw"",IF(RC[-2]=RC[-1],""ongewijzigd"",IF(RC[-2]<RC[-1],""gewijzigd (omlaag)"",IF(RC[-2]>RC[-1],""gewijzigd (omhoog)"",""""))))"
        .AutoFill Destination:=Range("H2:H" & Cells(Rows.Count, 1).End(xlUp).Row), Type:=xlFillDefault
    End With
    With Range("G2")
        .FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-6],Blad2!R2C2:R200C6,5,0)),0,VLOOKUP(RC[-6],Blad2!R2C2:R200C6,5,0))"
        .AutoFill Destination:=Range("G2:G" & Cells(Rows.Count, 1).End(xlUp).Row), Type:=xlFillDefault
    End With
       
    Range("I:I,C:E").Select
    Selection.ColumnWidth = 43
    
Range("A1").Resize(, 9) = Split("ID|nummer|risico|oorzaak|gevolg|huidige risicoscore|vorige risicoscore|mutatie|maatregelen", "|")

    Columns("A:B").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .ReadingOrder = xlContext
    End With
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 9
    End With
    
        Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .ReadingOrder = xlContext
    End With
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 9
    End With

    Range("A:B,F:H").Select
    Selection.Columns.AutoFit

Rows("1:" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFit

End Sub

En dit was m:

Code: 
Sub Stap1()

    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 18
    Range("AC:AD,P:T").Select
    Range("T1").Activate
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 13
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 15
    ActiveWindow.ScrollColumn = 16
    ActiveWindow.ScrollColumn = 17
    ActiveWindow.ScrollColumn = 18
    Range("AC:AD,P:T,U:AA").Select
    Range("AA1").Activate
    ActiveWindow.LargeScroll ToRight:=-1
    Range("AC:AD,P:T,U:AA,G:O").Select
    Range("O1").Activate
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Range("AC:AD,P:T,U:AA,G:O,C:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
    
    Range("B1").Select

Dim r As Long
Dim C As Range
Dim N As Long
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If
N = 0
For r = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(r).EntireRow) = 0 Then
Rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Copy
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("B:B").Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "ID"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "nummer"
    
    Range("I13") = "1"
    Range("I13").Copy
    Range("A1:A" & [a1].CurrentRegion.Rows.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
    Range("I13").Copy
    Range("B1:B" & [b1].CurrentRegion.Rows.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
    Range("I13").Copy
    Range("F1:F" & [f1].CurrentRegion.Rows.Count).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False

    Range("I13").ClearContents
    
        Range("F1").Select
    ActiveCell.FormulaR1C1 = "huidige score"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "risico"
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Tahoma"
        .FontStyle = "Vet"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("D1").Select
    Columns("F:G").Select
    Selection.ColumnWidth = 15
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "huidige risicoscore"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "vorige risicoscore"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "mutatie"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "maatregelen"
    Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Selection.Font.Bold = False
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "risico"
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Tahoma"
        .FontStyle = "Standaard"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "oorzaak"
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Tahoma"
        .FontStyle = "Standaard"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "gevolg"
    With ActiveCell.Characters(Start:=1, Length:=6).Font
        .Name = "Tahoma"
        .FontStyle = "Standaard"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Columns("A:I").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("G2").Select
    ActiveCell.FormulaR1C1 = ""
    Range("H2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-1]=0,""nieuw"",IF(RC[-2]=RC[-1],""ongewijzigd"",IF(RC[-2]<RC[-1],""gewijzigd (omlaag)"",IF(RC[-2]>RC[-1],""gewijzigd (omhoog)"",""""))))"
    Range("H2").Select
    Selection.AutoFill Destination:=Range("H2:H238"), Type:=xlFillDefault
    Range("H2:H238").Select
    ActiveWindow.SmallScroll Down:=-237
    Range("G2").Select

    ActiveCell.FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-6],Blad2!R2C2:R200C6,5,0)),0,VLOOKUP(RC[-6],Blad2!R2C2:R200C6,5,0))"
    Range("G2").Select
    Selection.AutoFill Destination:=Range("G2:G238"), Type:=xlFillDefault
    Range("G2:G238").Select
    ActiveWindow.SmallScroll Down:=-240
    
    Columns("H:H").Select
    Selection.Columns.AutoFit
    Columns("I:I").Select
    Selection.ColumnWidth = 43
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Cells.Select
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "ID"
    Range("A2").Select

ActiveWorkbook.Sheets(1).Range("A:A"). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete

On Error GoTo 0

    Columns("C:E").Select
    Range("E1").Activate
    Selection.ColumnWidth = 43
    Cells.Select
    Selection.Rows.AutoFit
    Range("A1").Select

End Sub

Van 282 naar 158 regels.

Zal nog niet PERFECT zijn, maar ik vind m af en zet m op opgelost, superbedankt Warme bakkertje en ExcelAmateur!!
 
Je kan er nog heel wat Select...Selection uitgooien maar zeker zou ik onderstaande als laatste 2 regels zetten, al is het maar voor de rust op je werkblad
Code: 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan