启用Excel宏的工作表在保存时出现错误

时间：2018-06-29 12:45:50

标签： excel excel-vba popup vba

我目前正在开发一种管理工具，旨在供整个办公室在日常管理中使用。这个基于excel的工具是一个多工作表工作簿，可以自动执行某些操作（使用 Private Sub Worksheet_Change ）或通过特定按钮进行操作。

特别地，目的之一是在我输入活动描述后自动创建正在运行的项目（参数）的验证列表，该列表保存在另一张表中。即使代码看起来运行顺利，每次我保存并关闭工作表时也会弹出以下错误： Excel error。 这似乎与我在另一张工作表（“日历”）中遇到的另一个问题类似，在该工作表中，代码必须再次执行类似的任务，以更改插入项目的单元格旁边的单元格的验证。

基本上，问题似乎主要是由此参数验证列表引起的，但我无法确切找到位置。你可以支持吗？

在此您可以找到两张纸的代码：

周

Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo exitsub
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim ws_proj_port As Worksheet
Dim ws_act_cat As Worksheet
Dim ws_curr_week As Worksheet
Dim ws_cal As Worksheet
Dim ws_graph As Chart
Dim proj_type As String
Dim act_proj_arr(100) As String
Dim act_proj_val As String
Dim lastrow_act As Integer
Dim hrs_done As Double
Dim hrs_day As Double
Dim hrs_week As Double
Dim hrs_marker As Double


Dim i As Integer
Dim j As Integer
Dim r As Integer


Set ws_curr_week = ActiveSheet
Set ws_proj_port = Sheets("Projects portfolio")
Set ws_act_cat = Sheets("Activity categories")
Set ws_cal = Sheets("Calendar")


proj_type = ""
proj_color = ""
proj_name = ""
act_cat = ""
act_cat_j = ""
proj_imp = ""

If Target.row > 2 And Target.row < 34 And Target.Column < 16 Then
    If Target.Column = 1 Then
        If Target.Value <> "" Then
            ws_curr_week.Cells(Target.row, Target.Column + 1).Value = "- to be selected -"

            '------- START project validation list creation
            ws_curr_week.Activate
            ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
            ws_curr_week.Cells(Target.row, Target.Column + 1).Select
            With Selection.Validation
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=week_proj"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
            End With
            '----- END project validation list creation
        Else
            ws_curr_week.Cells(Target.row, Target.Column + 1).ClearContents
            ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
            ws_curr_week.Cells(Target.row, Target.Column + 2).ClearContents
            ws_curr_week.Cells(Target.row, Target.Column + 2).Validation.Delete
            ws_curr_week.Cells(Target.row, 7).ClearContents
        End If
    ElseIf Target.Column = 2 Then
        If Target.Value <> "" Then
        '------- START activity validation list creation
            ws_proj_port.Activate
            ws_proj_port.Range("A2").Select
            Selection.End(xlDown).Select
            r = ActiveCell.row
            proj_matrix = "A2:H" & r
            proj_name = ws_curr_week.Cells(Target.row, Target.Column).Value
            proj_type = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 2, False)
            proj_color = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 3, False)

            ws_act_cat.Activate
            ws_act_cat.Range("D2").Select
            Selection.End(xlDown).Select
            lastrow_act = ActiveCell.row
            j = 0
            i = 2

            If proj_type = "Linework" Then
                For i = 2 To lastrow_act
                    If ws_act_cat.Cells(i, 1).Value = proj_type And ws_act_cat.Cells(i, 2).Value = proj_name Then
                        act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
                        j = j + 1
                    End If
                Next i
            Else
                For i = 2 To lastrow_act
                    If ws_act_cat.Cells(i, 1).Value = proj_type Then
                        act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
                        j = j + 1
                    End If
                Next i
            End If

            act_proj_val = Join(act_proj_arr, ",")

            ws_curr_week.Activate
            ws_curr_week.Cells(Target.row, Target.Column + 1).Value = "- to be selected -"
            ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
            ws_curr_week.Cells(Target.row, Target.Column + 1).Select
            With Selection.Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=act_proj_val
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
            '------- END activity validation list creation

            'Set Importance Y/N
            ws_curr_week.Cells(Target.row, 7).Value = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 7, False)
        Else
            ws_curr_week.Cells(Target.row, 7).ClearContents
            ws_curr_week.Cells(Target.row, Target.Column + 1).ClearContents
            ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
        End If
    ElseIf Target.Column = 10 Or Target.Column = 11 Then
        If Target.Value <> "" Then
            ws_curr_week.Cells(Target.row, 12).Value = Format(Date, "dd/mm", vbMonday, vbFirstJan1)
            ws_curr_week.Cells(Target.row, 13).Value = Application.Text(Date, "[$-809]dddd")
        Else
            ws_curr_week.Cells(Target.row, 12).ClearContents
            ws_curr_week.Cells(Target.row, 13).ClearContents
        End If
        calc_hrs hrs_done, hrs_day, hrs_week, hrs_marker
        create_graph hrs_done, hrs_day, hrs_week, hrs_marker
    ElseIf Target.Column = 4 And ws_curr_week.Range("P2") <> "Sunday" And ws_curr_week.Range("P2") <> "Saturday" And ws_curr_week.Range("P2") <> "Monday" Then
        calc_hrs hrs_done, hrs_day, hrs_week, hrs_marker
        create_graph hrs_done, hrs_day, hrs_week, hrs_marker
    End If
End If

Target.Cells.Select
exitsub:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

日历

Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo exitsub
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim ws_proj_port As Worksheet
Dim ws_act_cat As Worksheet
Dim ws_cal As Worksheet
Dim ws_hid As Worksheet
Dim act_proj_arr(100) As String
Dim act_proj_val As String
Dim proj_name As String
Dim last_proj As Integer


Set ws_proj_port = Sheets("Projects portfolio")
Set ws_act_cat = Sheets("Activity categories")
Set ws_cal = Sheets("Calendar")
Set ws_hid = Sheets("Hidden")

If Target.Column > 2 And Target.Column < 14 And Target.row < 16 Then
    If Target.Column Mod 2 <> 0 Then
        If Target.Value = "-" Then
            ws_cal.Cells(Target.row, Target.Column + 1).Value = "-"

            ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = -0.249977111117893
                .PatternTintAndShade = 0
            End With

            With Selection.Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With

            With Selection
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            ws_cal.Cells(Target.row, Target.Column).Select

        ElseIf Target.Value = "Lunch" Then
            ws_cal.Cells(Target.row, Target.Column + 1).ClearContents
            ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).Select
            With Selection
                .Style = "Accent2"
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With


        ElseIf Target.Value <> "" Then
            '------- START formatting
            proj_name = ws_cal.Cells(Target.row, Target.Column).Value
            ws_proj_port.Activate
            ws_proj_port.Range("A2").Select
            Selection.End(xlDown).Select
            last_proj = ActiveCell.row
            proj_arr = ws_proj_port.Range("A1:A" & last_proj)
            proj_row = Application.Match(proj_name, proj_arr, 0)
            ws_proj_port.Activate
            ws_proj_port.Range("H" & proj_row).Select
            Selection.Copy

            ws_cal.Activate
            ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).PasteSpecial xlPasteFormats
            ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).Interior.Color = ws_proj_port.Range("H" & proj_row).Interior.Color
            ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).WrapText = True


            Application.CutCopyMode = False

            '------- END formatting


            '------- START activity validation list creation
                ws_proj_port.Activate
                ws_proj_port.Range("A2").Select
                Selection.End(xlDown).Select
                r = ActiveCell.row
                proj_matrix = "A2:H" & r
                proj_name = ws_cal.Cells(Target.row, Target.Column).Value
                proj_type = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 2, False)
                proj_color = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 3, False)

                ws_act_cat.Activate
                ws_act_cat.Range("D2").Select
                Selection.End(xlDown).Select
                lastrow_act = ActiveCell.row

                j = 0
                i = 2

                If proj_type = "Linework" Then
                    For i = 2 To lastrow_act
                        If ws_act_cat.Cells(i, 1).Value = proj_type And ws_act_cat.Cells(i, 2).Value = proj_name Then
                            act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
                            j = j + 1
                            Else
                        End If
                    Next i
                    Else
                    For i = 2 To lastrow_act
                        If ws_act_cat.Cells(i, 1).Value = proj_type Then
                            act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
                            j = j + 1
                            Else
                        End If
                    Next i
                End If

                act_proj_val = Join(act_proj_arr, ",")

                ws_cal.Activate
                ws_cal.Cells(Target.row, Target.Column + 1).Value = "- to be selected -"
                ws_cal.Cells(Target.row, Target.Column + 1).Validation.Delete
                ws_cal.Cells(Target.row, Target.Column + 1).Select
                With Selection.Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=act_proj_val
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
                End With
                '------- END activity validation list creation

                Else
                ws_cal.Cells(Target.row, Target.Column).Select
                Call cell_cal_format
                ws_cal.Cells(Target.row, Target.Column + 1).ClearContents
                ws_cal.Cells(Target.row, Target.Column + 1).Validation.Delete
                ws_cal.Cells(Target.row, Target.Column + 1).Select
                Call cell_cal_format
                ws_cal.Cells(Target.row, Target.Column).Select
        End If
    End If
End If

exitsub:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub cell_cal_format()
Selection.Style = "Normal"
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
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

谢谢！

Alessio

0 个答案:

没有答案
相关问题
最新问题