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

Jonathan1982

Gebruiker
Lid geworden
25 dec 2010
Berichten
56
Laatste uitdaging. Biertje voor degene die met de oplossing komt.

Om de zoveel tijd moet ik gegevens herijken. Dit betekent dat ik het volgende heb:
een oud werkblad (1)
een nieuw werkblad (2).

Tevens heeft elke rij een score in zich zitten in kolom H. Wat ik in principe wil is dat de oude scores met de nieuwe vergeleken worden.

Dus de scores van H in werkblad (1) komen in kolom B van werkblad (3) (hulpwerkblad)
De scores van H in werkblad (2) komen in kolom C van werkblad (3)
en dan in kolom D van werkblad (3)
- nieuw (als er geen score is voor B is)
- onveranderd (als B en C gelijk zijn)
- gewijzigd omlaag (als C lager is dan B)
- gewijzigd omhoog (als C hoger is dan B)

Voor zover geen probleem. Een ALS-formule die B en C vergelijkt.

Probleem is echter dat het kan zijn dat (2) (nieuwe werkblad) ten op zichte van (1) (oude werkblad) misschien enkele nieuwe regels (geïdentificeerd door een nummer) bevat en misschien enkele regels niet meer bevat.

Wat ik dus wil is:
De regels van (2) kopiëren naar (3) waarbij de scores in kolom H in kolom C van (3)terecht komen.
De regels van (1) kopiëren naar (3) waarbij

De regels in (1) die niet al in (3) zitten komen te vervallen.
Van de regels in (1) die reeds in (3) zitten, wordt de score van die regel (in cel H) geplaatst in kolom B van (3)
Van de regels die overblijven komt in kolom B van (3) niks of nul.

Ik kan me voorstellen dat het nog niet helemaal duidelijk is, dus ik zal een voorbeeldje toevoegen.

Bekijk bijlage test mappen vergelijken.xls

SUCCES!
 
Klein voorzetje.

Met vert.zoeken.

Jij ook succes met het verder verbeteren.

mvg Peter
 

Bijlagen

Te gek. Heb m nog iets verbeterd, zodat als de uitkomst #N/B is, dan staat er 0. En als er 0 staat in de tweede kolom, dan komt er in de laatste kolom te staan: vervallen

Bekijk bijlage mappen vergelijken.xls

Deze excel heb ik echter versimpeld, ga nu even kijken hoe ik het handig toe kan passen op de bladen die ik als input krijg.

Super.
 
Ik was er bijna uit. Mijn input heeft echter andere kolommen. In plaats van H is het F en in plaats van A is het B. Zou toch geen probleem moeten zijn?

Bijgevoegd voorbeeld:

Eerste 5 rijen heb ik A vervangen voor B en H vervangen door F, dan geeft ie een foutmelding.

Rijen erna werken prima. Die werkt met A en H. Voor de rest precies hetzelfde volgens mij....
 

Bijlagen

Laatst bewerkt:
Jonathan1982 zei:
Ik was er bijna uit. Mijn input heeft echter andere kolommen. In plaats van H is het F en in plaats van A is het B. Zou toch geen probleem moeten zijn?

Bijgevoegd voorbeeld:

Eerste 5 rijen heb ik A vervangen voor B en H vervangen door F, dan geeft ie een foutmelding.

Rijen erna werken prima. Die werkt met A en H. Voor de rest precies hetzelfde volgens mij....
Klik om te vergroten...

Ben er stiekem alweer uit.... kolomindexgetal stond verkeerd...
 
Hij doet het ook in mijn originele bestand! Top!

Heb nog 1 vraag, maar ik weet niet of ik die hier moet stellen of ergens anders. Ik heb in mijn macro 2 keer een moment zitten waarin ik een formule doorvoer. Daarmee voer ik m door tot 200, in de hoop dat het nooit boven de 200 uit komt. Maar is het ook mogelijk dat het alleen doorgevoerd wordt tot en met het punt waarop er nog waardes zijn? En ik vraag mij af welke stappen ik kan verwijderen uit mijn macro (zitten nogal wat overbodige stappen in waarschijnlijk, heb namelijk een aantal macro's samengevoegd) De eerste vraag is vanzelfsprekens belangrijker voor me dan de tweede vraag.

Mijn macro is alsvolgt, het stukje doorvoeren heb ik onderstreept (onderaan):
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
 
Laatst bewerkt:
Jonathan1982,

De volgende keer moet je de code selecteren en boven in het menu op # klikken, komt de code netjes in een apart vak te staan. :thumb:

De code moet je nog een beetje vereenvoudigen (korter maken)
 
Ik vermoed dat het een en ander aan selecteren en scrollen eventueel weg kan, maar merk ook dat als ik dat soms weg haal, dat de opvolgende code/subcode zijn werk niet doet...
 
Jonathan1982,
b.v.b.
Code: 
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"
Word b.v.b. dit.
Code: 
Range("F1") = "huidige risicoscore"
Range("G1") = "vorige risicoscore"
Range("H1") = "mutatie"
Range("I1") = "maatregelen"
 
Top. Die heb ik verwerkt, en de eerste rij codes heb ik ook vervangen.

Dit heb ik nu nog over:

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("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") = "huidige risicoscore"
Range("G1") = "vorige risicoscore"
Range("H1") = "mutatie"
Range("I1") = "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
 
Kijk eens of dit ook werkt.
Verander dit
Code: 
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
In dit
Code: 
Columns("B:B").Copy Columns("A:A")
 
ExcelAmateur zei:
Kijk eens of dit ook werkt.
Verander dit
Code: 
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
In dit
Code: 
Columns("B:B").Copy Columns("A:A")
Klik om te vergroten...

Is wel een paste-special hè? Zal s kijken... inmiddels weer wat ingekort:


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("A1") = "ID"
    Range("B1") = "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") = "huidige score"
    Range("C1") = "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") = "huidige risicoscore"
Range("G1") = "vorige risicoscore"
Range("H1") = "mutatie"
Range("I1") = "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") = "risico"
    Range("D1") = "oorzaak"
    Range("E1") = "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("H2") = _
        "=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") = _
        "=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
 
Zo lang je niets opslaat gebeurd er met je code ook niets. (kun je altijd nog terug)
Maak voor de zekerheid een copy van je bestandje.
Er staan nog meer regels in met FormulaR1C1 die kun je ook nog aan passen.

Maar als Warme bakkertje er naar kijkt, die kan hem pas echt kort maken.
Zo'n ster ben ik ook weer niet.
 
Werkt niet. Verlies dan bepaalde waardes. Omdat hij de blanks over moet slaan volgens mij.

Maar eeeeh... mijn grootste probleem was dat ik bij het doorvoeren door wil voeren over alle rijen waarin waardes staan. Ik heb m nu ingesteld op rond de 250, en dan hoop ik dat veilig ben.

Daar komt weer bij dat ik achteraf weer een code moet toevoegen zodat de ongebruikte rijen verwijderd worden.

Code: 
 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
    [U]Selection.AutoFill Destination:=Range("H2:H238"),[/U] Type:=xlFillDefault
    Range("H2:H238").Select
    [U]ActiveWindow.SmallScroll Down:=-237[/U]    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
    [U]Selection.AutoFill Destination:=Range("G2:G238"), [/U]Type:=xlFillDefault
    Range("G2:G238").Select
    [U]ActiveWindow.SmallScroll Down:=-240[/U]
 
Laatst bewerkt:
Daarom altijd een kopy van je bestandje maken, kun je altijd op terug vallen.
Ik zie ook dat je de code bent vergeten te selecteren en op # te klikken.
Suc6
 
Dank, ik dacht dat het qua ruimte niet zoveel uitmaakte met zo'n korte code.

Maar over het doorvoeren van (formules in) cellen kan je me niks vertellen?
 
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
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan