时间戳

首页 > 解决方案 > 更改单元格颜色后 Excel 崩溃

excel - 更改单元格颜色后 Excel 崩溃

问题描述

我们有一个在办公室使用的文件。它是由不再在这里工作的人制作的。

有一段时间，当我们更改任何单元格颜色时，文件会不断崩溃。文件中有一些宏，我自己也知道一点 VBA，但我找不到任何问题。

我希望这里有人可以帮助我。所有宏都是通过按钮调用的，当我删除模块中的所有代码时，我可以更改单元格颜色。

那么是模块损坏还是代码有问题，有什么想法吗？

代码一点也不整洁，对此我深表歉意。

这是代码：

Sub Info()

MsgBox "Grijze cellen bevatten formules -> bij voorkeur niet wijzigen" & vbCr & vbCr & _
        "Per regel wordt één ruimte ingevoerd, de kolom 'aantal' wordt alleen bij totalen meegenomen"     & vbCr & vbCr & _
        "Let op met standaard plakken omdat ook de voorwaardelijke opmaak (lijsten) worden     gekopieerd" & vbCr & _
        "    Gebruik liever 'waarden plakken' als kopieren noodzakelijk is" & vbCr & vbCr & _
        "Geen regels invoegen, gebruik de kopieerknoppen bovenin" & vbCr & _
        "Regels in zijn geheel verwijderen (rechts klikken op het regelnummer)" & vbCr & vbCr & _
        "Maximale waarde van bouwbesluit en eigen invoer wordt gehanteerd" & vbCr & vbCr & _
        "Overstort: " & vbCr & _
        "- Invullen niet noodzakelijk" & vbCr & _
        "- Dient bij beide ruimtes te worden ingevuld" & vbCr & _
        "- vb. de overstort van gang naar badkamer dient te worden ingevuld als afvoer van de gang EN     toevoer in de badkamer" & vbCr & vbCr & _
        "Mogelijke foutmelding over kringverwijzingen bij openen negeren" & vbCr & vbCr & _
        "Standaard verdiepingshoogte controleren wanneer regel wordt ingevoegd" & vbCr & vbCr & _
        "Het OVB-blad filtert automatisch op het streepje in de kolom 'Voldoet'," & vbCr & _
        "wanneer je een ruimte toch in het OVB-blad wilt laten zien dient het" & vbCr & _
        "streepje vervangen te worden", vbInformation, "INSTRUCTIES"
        
End Sub


Sub knopwoningbouw()

Application.ScreenUpdating = False

Sheets("Algemeen").Rows("3002").Copy
Rows("1").Select
Selection.Insert Shift:=xlDown

Application.CutCopyMode = False
ActiveSheet.Calculate

Sheets("Algemeen").Rows("2").Delete

Sheets("Algemeen").Rows("1").Hidden = False

Sheets("Algemeen").Rows("10").Hidden = True

Sheets("Algemeen").Rows("11").Hidden = False

Sheets("Algemeen").Rows("38").Hidden = True

Sheets("Sjabloon").Rows("81:97").Copy
Rows("39").Select
Selection.Insert Shift:=xlDown

Application.CutCopyMode = True
ActiveSheet.Calculate

Sheets("Algemeen").Columns("G:H").Hidden = True
Sheets("Algemeen").Columns("J:M").Hidden = True
Sheets("Algemeen").Columns("O").Hidden = True
Sheets("Algemeen").Columns("Y").Hidden = True
Sheets("Algemeen").Columns("AF:AI").Hidden = True
Sheets("Algemeen").Columns("AK:DE").Hidden = True

Sheets("Algemeen").Columns("F").ColumnWidth = 20
Sheets("Algemeen").Columns("N").ColumnWidth = 17
Sheets("Algemeen").Columns("Q").ColumnWidth = 8.57
Sheets("Algemeen").Columns("R").ColumnWidth = 18
Sheets("Algemeen").Columns("AD").ColumnWidth = 8.43
Sheets("Algemeen").Columns("AE").ColumnWidth = 20
Sheets("Algemeen").Columns("AJ").ColumnWidth = 8

Sheets("Algemeen").Rows("3017:3019").Delete


End Sub


Sub knoputiliteitsbouw()

Application.ScreenUpdating = False

Sheets("Algemeen").Rows("3").RowHeight = 20

Sheets("Algemeen").Rows("3000").Copy
Rows("1").Select
Selection.Insert Shift:=xlDown

Application.CutCopyMode = False
ActiveSheet.Calculate

Sheets("Algemeen").Rows("2").Delete

Sheets("Algemeen").Rows("1").Hidden = False

Sheets("Algemeen").Rows("10").Hidden = True

Sheets("Algemeen").Rows("11:38").Hidden = False

Sheets("Sjabloon").Rows("63:79").Copy
Rows("39").Select
Selection.Insert Shift:=xlDown

Application.CutCopyMode = True
ActiveSheet.Calculate

Sheets("Algemeen").Rows("3017:3019").Delete

Sheets("Algemeen").Columns("AL").Hidden = True

End Sub

Sub woningb()

Answer = MsgBox("Verdieping wordt boven de geselecteerde cel ingevoegd." & vbCr & _
            "(Dus ook als dit midden in een andere verdieping is)" & vbCr & vbCr & _
            "Wilt u doorgaan?", vbYesNo, "LET OP!")

If Answer = vbNo Then
    MsgBox "Invoegen verdieping beëindigd", vbCritical, "Invoegen beëindigd"
    Exit Sub
End If

Sheets("Sjabloon").Rows("81:97").Copy
Rows(Selection.Row).Select
Selection.Insert Shift:=xlDown

Application.CutCopyMode = False
ActiveSheet.Calculate

End Sub

Sub utiliteitsb()

Answer = MsgBox("Verdieping wordt boven de geselecteerde cel ingevoegd." & vbCr & _
            "(Dus ook als dit midden in een andere verdieping is)" & vbCr & vbCr & _
            "Wilt u doorgaan?", vbYesNo, "LET OP!")

If Answer = vbNo Then
    MsgBox "Invoegen verdieping beëindigd", vbCritical, "Invoegen beëindigd"
    Exit Sub
End If

Sheets("Sjabloon").Rows("63:79").Copy
Rows(Selection.Row).Select
Selection.Insert Shift:=xlDown

Application.CutCopyMode = False
ActiveSheet.Calculate
End Sub


Sub ovbutiliteitsbouw()
'
'   Macro kopieert voor OVB UTILITEITSBOUW relevante informatie naar een nieuw blad
'   RPR, 03/2012

Answer = MsgBox("Door deze handeling wordt het huidige blad ovb utiliteitsbouw verwijderd (indien     aanwezig)." & vbCr & _
        "Het blad zal overnieuw worden opgebouwd aan de hand van de gegevens" & vbCr & _
        "op het blad 'Algemeen'." & vbCr & vbCr & _
        "Wilt u doorgaan?", vbYesNo, "LET OP!")

If Answer = vbNo Then
MsgBox "Update van het OVB UTILITEITSBOUW-blad is beëindigd", vbCritical, "Update beëindigd"
Exit Sub
End If

'TER VOORKOMING VAN EPILEPTISCHE AANVAL
Application.ScreenUpdating = False
 
'OUDE BLAD VERWIJDEREN EN NIEUWE AANMAKEN
On Error GoTo Nosuchsheet
Application.DisplayAlerts = False
Sheets("OVB UTILITEITSBOUW").Select
ActiveWindow.SelectedSheets.Delete

Nosuchsheet:
Application.DisplayAlerts = True

Sheets("Data").Visible = True

Sheets("DATA").Select
Sheets.Add
ActiveWorkbook.ActiveSheet.Name = "OVB UTILITEITSBOUW"
ActiveWindow.DisplayZeros = False

'Kopieer kopregels
Sheets("Algemeen").Select
Range("A3:Q10").Select
Selection.Copy
Sheets("OVB UTILITEITSBOUW").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste

'Waarschuwing linksboven
With Range("B1")
    .Value = "LET OP! Aanpassingen dienen te worden gemaakt in blad 'Algemeen'. Aanpassingen gemaakt     in dit blad gaan verloren bij de volgende update."
    .Font.Bold = True
    .Font.Color = -16711932
    .Font.Size = 15
    End With


'Dubbele lijn
Rows("35:35").Select
Application.CutCopyMode = False

With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDouble
    .ColorIndex = 0
 '      .TintAndShade = 0
    .Weight = xlThick
End With

'Rijhoogten kopieren
Sheets("Algemeen").Select
Rows("38:3000").Copy

Sheets("OVB UTILITEITSBOUW").Select
Rows("35:2997").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

Selection.Clear

'Ventilatietabel per kolom

'Ruimteeigenschappen tot 'hoogte'
Sheets("Algemeen").Select
Range("A38:G3000").Select
Selection.Copy

Sheets("OVB UTILITEITSBOUW").Select
Range("A35").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
    

'BOUWBESLUIT
Sheets("Algemeen").Select
Range("U38:Y3000").Copy
   
Sheets("OVB UTILITEITSBOUW").Select
Range("H35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    

'AANWEZIG
Sheets("Algemeen").Select
Range("AC38:AC3000").Copy
   
Sheets("OVB UTILITEITSBOUW").Select
Range("M35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


'VOLDOET?
Sheets("Algemeen").Select
Range("AJ38:AJ3000").Copy
   
Sheets("OVB UTILITEITSBOUW").Select
Range("N35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'LIJNTJES BIJWERKEN
For r = 38 To 2997
    
    Range("Q" & r).Select
    
    If Selection.Interior.ColorIndex = 15 Then
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
'               .TintAndShade = 0
            .Weight = xlMedium
        End With
    End If
    
Next r

'LEGE RIJEN VERWIJDEREN
Rows("30:34").Select
Selection.Delete Shift:=xlUp

Rows("11:29").Select
Selection.Delete Shift:=xlUp


'Afdrukbereik instellen
For x = 1 To 3000
If Range("A" & x).Interior.ColorIndex = 15 Then
    Laatste = x
End If
Next

PA = "$A$3:$N$" & Laatste

With ActiveSheet.PageSetup
    .PrintArea = PA
    .Orientation = xlPortrait
    .PaperSize = xlPaperA4
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 999
End With


ActiveWindow.View = xlPageBreakPreview

'TERUG NAAR BOVEN ETC
Sheets("Algemeen").Select
Range("A20").Select
Sheets("OVB UTILITEITSBOUW").Select
Sheets("Data").Visible = False
Range("A1").Select
Application.CutCopyMode = False

'AUTOFILTER
Columns("N").Select
Selection.AutoFilter
ActiveSheet.Range("N1:N3000").AutoFilter Field:=1, Criteria1:="<>-"

'BORDER
Sheets("OVB UTILITEITSBOUW").Range("A3:N9").Select
Selection.BorderAround Weight:=xlMedium

End Sub



Sub ovbwoningbouw()
'
'   Macro kopieert voor OVB WONINGBOUW relevante informatie naar een nieuw blad
'   RPR, 03/2012

Answer = MsgBox("Door deze handeling wordt het huidige blad ovb woningbouw verwijderd (indien aanwezig)."     & vbCr & _
        "Het blad zal overnieuw worden opgebouwd aan de hand van de gegevens" & vbCr & _
        "op het blad 'Algemeen'." & vbCr & vbCr & _
        "Wilt u doorgaan?", vbYesNo, "LET OP!")

If Answer = vbNo Then
MsgBox "Update van het OVB UTILITEITSBOUW-blad is beëindigd", vbCritical, "Update beëindigd"
Exit Sub
End If

'TER VOORKOMING VAN EPILEPTISCHE AANVAL
Application.ScreenUpdating = False
 
'OUDE BLAD VERWIJDEREN EN NIEUWE AANMAKEN
On Error GoTo Nosuchsheet
Application.DisplayAlerts = False
Sheets("OVB WONINGBOUW").Select
ActiveWindow.SelectedSheets.Delete

Nosuchsheet:
Application.DisplayAlerts = True

Sheets("Data").Visible = True

Sheets("DATA").Select
Sheets.Add
ActiveWorkbook.ActiveSheet.Name = "OVB WONINGBOUW"
ActiveWindow.DisplayZeros = False

'Kopieer kopregels
Sheets("Algemeen").Select
Range("A3:Q11").Select
Selection.Copy
Sheets("OVB WONINGBOUW").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste

    Range("A3:Q11").Select
Application.CutCopyMode = False

With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDouble
    .ColorIndex = 0
 '      .TintAndShade = 0
    .Weight = xlThick
End With

'Waarschuwing linksboven
 With Range("B1")
    .Value = "LET OP! Aanpassingen dienen te worden gemaakt in blad 'Algemeen'. Aanpassingen gemaakt         in dit blad gaan verloren bij de volgende update."
    .Font.Bold = True
    .Font.Color = -16711932
    .Font.Size = 15
End With

'Dubbele lijn
Rows("35:35").Select
Application.CutCopyMode = False

With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDouble
    .ColorIndex = 0
 '      .TintAndShade = 0
    .Weight = xlThick
End With

'Rijhoogten kopieren
Sheets("Algemeen").Select
Rows("38:3000").Copy

Sheets("OVB WONINGBOUW").Select
Rows("35:2997").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

Selection.Clear


'Ventilatietabel per kolom

'Ruimteeigenschappen tot 'oppervlakte'
Sheets("Algemeen").Select
Range("A38:F3000").Select
Selection.Copy

Sheets("OVB WONINGBOUW").Select
Range("A35").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
    
'OPPERVLAKTE
Sheets("Algemeen").Select
Range("N38:N3000").Copy
   
Sheets("OVB WONINGBOUW").Select
Range("G35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    'CAPACITEIT ROOSTER
Sheets("Algemeen").Select
Range("R38:R3000").Copy
   
Sheets("OVB WONINGBOUW").Select
Range("H35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'BOUWBESLUIT (1/2)
Sheets("Algemeen").Select
Range("U38:X3000").Copy
   
Sheets("OVB WONINGBOUW").Select
Range("I35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    'BOUWBESLUIT (2/2)
Sheets("Algemeen").Select
Range("Z38:Z3000").Copy
   
Sheets("OVB WONINGBOUW").Select
Range("M35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    

'AANWEZIG
Sheets("Algemeen").Select
Range("AC38:AE3000").Copy
   
Sheets("OVB WONINGBOUW").Select
Range("N35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


'VOLDOET?
Sheets("Algemeen").Select
Range("AJ38:AJ3000").Copy
   
Sheets("OVB WONINGBOUW").Select
Range("Q35").Select

Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'LIJNTJES BIJWERKEN
For r = 38 To 2997
    
    Range("P" & r).Select
    
    If Selection.Interior.ColorIndex = 15 Then
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
'               .TintAndShade = 0
            .Weight = xlMedium
        End With
    End If
    
Next r

'LEGE RIJEN VERWIJDEREN
Rows("30:34").Select
Selection.Delete Shift:=xlUp

Rows("11:29").Select
Selection.Delete Shift:=xlUp


'Afdrukbereik instellen
For x = 1 To 3000
If Range("A" & x).Interior.ColorIndex = 15 Then
    Laatste = x
End If
Next

PA = "$A$3:$Q$" & Laatste

With ActiveSheet.PageSetup
    .PrintArea = PA
    .Orientation = xlPortrait
    .PaperSize = xlPaperA4
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 999
End With


ActiveWindow.View = xlPageBreakPreview

'TERUG NAAR BOVEN ETC
Sheets("Algemeen").Select
Range("A20").Select
Sheets("OVB WONINGBOUW").Select
Sheets("Data").Visible = False
Range("A1").Select
Application.CutCopyMode = False

Sheets("OVB WONINGBOUW").Rows("11").Hidden = False

'AUTOFILTER
Columns("Q").Select
Selection.AutoFilter
ActiveSheet.Range("Q1:Q3000").AutoFilter Field:=1, Criteria1:="<>-"

'BORDER
Sheets("OVB WONINGBOUW").Range("A3:N9").Select
Selection.BorderAround Weight:=xlMedium

'SAMENGEVOEGDE CELLEN SPLITSEN
Sheets("OVB WONINGBOUW").Range("D4:M9").Select
Selection.UnMerge

'FILTER NATUURLIJK
Dim cell As Range
For Each cell In Sheets("Algemeen").Range("R10")
If cell.Value = "nee" Then
Sheets("OVB WONINGBOUW").Columns("H").Select
Selection.EntireColumn.Hidden = True
Sheets("OVB WONINGBOUW").Columns("P").ColumnWidth = 0.1

End If
Next cell


End Sub

Sub printbereik()

Application.ScreenUpdating = False

For x = 1 To 3000
If Range("A" & x).Interior.ColorIndex = 15 Then
    Laatste = x
End If
Next

PA = "$A$3:$AK$" & Laatste

With ActiveSheet.PageSetup
    .PrintArea = PA
    .Orientation = xlLandscape
    .PaperSize = xlPaperA4
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 999
End With


ActiveWindow.View = xlPageBreakPreview

End Sub


Sub copyUp()
Rows(Selection.Row).Select
Selection.Copy
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
End Sub


Sub copyDown()
Rows(Selection.Row).Select
Selection.Copy
Selection.Insert Shift:=xlUp
Application.CutCopyMode = False
End Sub

标签： excelvba

解决方案

我认为你应该减少数据，然后再试一次！

推荐阅读