时间戳

首页 > 解决方案 > Excel VBA - 如果填写了其他单元格，则不允许空白

excel - Excel VBA - 如果填写了其他单元格，则不允许空白

问题描述

我正在寻找添加到下面的代码。我有一个电子表格，最终用户可以在其中列出任务列表并为每个任务分配小时数，然后点击一个按钮并将其提交给任务跟踪器。

我要防止的是最终用户输入任务并忘记输入时间，当提交给跟踪器时，我们的总数会因为空白而关闭。

在下面的代码中，您会看到它在 D 列中查找模型，在 E 列中查找模型时间，然后在 I 列中查找图纸，在 J 列中查找绘图时间。但我不确定如何说“如果 D10 中有数据而 E10 中没有数据，和/或如果 I3 中有数据但 J3 中没有数据，则显示错误消息“任务没有分配小时数。”

任何帮助，将不胜感激！！

Function compareCols(rng As Range) As String
    Dim rngC1 As Range, cel As Range, i As Long
    Set rngC1 = rng.Columns(1).SpecialCells(xlCellTypeConstants)
    For Each cel In rngC1.Cells
         If cel.Value <> "" And cel.Offset(0, 1) = "" Then
            compareCols = "No hours in " & cel.Offset(0, 1).Address: Exit Function
         End If
    Next cel
    compareCols = "OK"
End Function

Sub CAD_Task_Entry()
Dim InstalDesc As String
Dim Model As Range
Dim Drawing As Range
Dim Index As Long
Dim m As Long, n As Long

Application.ScreenUpdating = False
'Copy data from the input screen to the task list.
Sheets("Task Entry Form").Select
InstalDesc = Range("D3")
Set Model = Range("D5", Cells(Rows.Count, "D").End(xlUp)).Resize(, 2)
Set Drawing = Range("I5", Cells(Rows.Count, "I").End(xlUp)).Resize(, 2)

Index = Range("Q2")
With Sheets("Task List")
    'get first row
    n = .Range("D:X").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If n = 3 Then n = 4 Else n = n + 2
    
    'color first row
    .Range("A" & n & ":Z" & n).Interior.Color = 15189684
    .Cells(n, "D") = InstalDesc & " Summary"
    
    'verify hours are filled in on tasks
    Dim strOK As String
    strOK = compareCols(Model)
    If strOK <> "OK" Then MsgBox strOK: Exit Sub
  
    strOK = "": strOK = compareCols(Drawing)
    If strOK <> "OK" Then MsgBox strOK: Exit Sub
    
If Model.Rows.Count > 1 Then
    Model.Columns(1).SpecialCells(xlCellTypeConstants).Copy
    .Cells(n + 1, "E").PasteSpecial xlPasteValues
    Model.Columns(2).SpecialCells(xlCellTypeConstants).Copy
    .Cells(n + 1, "Q").PasteSpecial xlPasteValues
  Else
    Model.Columns(1).Copy
    .Cells(n + 1, "E").PasteSpecial xlPasteValues
    Model.Columns(2).Copy
    .Cells(n + 1, "Q").PasteSpecial xlPasteValues
  End If
  If Drawing.Rows.Count > 1 Then
    Drawing.Columns(1).SpecialCells(xlCellTypeConstants).Copy
    .Cells(n + Model.Rows.Count + 1, "F").PasteSpecial xlPasteValues
    Drawing.Columns(2).SpecialCells(xlCellTypeConstants).Copy
    .Cells(n + Model.Rows.Count + 1, "Q").PasteSpecial xlPasteValues
  Else
    Drawing.Columns(1).Copy
    .Cells(n + Model.Rows.Count + 1, "F").PasteSpecial xlPasteValues
    Drawing.Columns(2).Copy
    .Cells(n + Model.Rows.Count + 1, "Q").PasteSpecial xlPasteValues
End If

    'get last row after inserting data
    m = .Range("D:X").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'create formulas
    'add backchecking and forumla
    .Cells(m + 1, 7) = "Backchecking"
    .Cells(m + 1, 17) = "=SUM(Q" & n + 1 & ":Q" & m & ")/2"
    'projected hours
    .Cells(n, "Q") = "=SUM(Q" & n + 1 & ":Q" & m + 1 & ")"
    'actual hours
    .Cells(n, "S") = "=SUM(S" & n + 1 & ":S" & m + 1 & ")"
    'install % complete
    .Cells(n, "U") = "=SUMPRODUCT(V" & n + 1 & ":V" & m + 1 & "+X" & n + 1 & ":X" & m + 1 & ",R" & n + 1 & ":R" & m + 1 & ")/SUM(R" & n + 1 & ":R" & m + 1 & ")"
        .Cells(n, "U").NumberFormat = "0%"
    'weight
    .Cells(n + 1, "R") = "=Q" & n + 1 & "/$Q$" & n
    .Cells(n + 1, "R").AutoFill Destination:=.Range("R" & n + 1 & ":R" & m + 1)
        'formatting weight
        With Range("R" & n & ":R" & m).Select
        Selection.NumberFormat = "0.00"
        End With
        
    'create dropdowns
    'assigned to
     With .Range("T" & n & ":T" & m + 1).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Summary!$H$3:$H$14"
     End With
     
     'stages
     Sheets("Task List").Select
     For i = n + 1 To m + 1
        If Cells(i, 5).Value <> "" Then
            .Range("W" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Data!$B$4:$B$9"
            .Cells(i, "V") = "=IFERROR(VLOOKUP(W" & i & ",Data!$B$4:$C$9,2,FALSE),"""")"
            .Range("W" & i).Value = "Not Started"
            .Range("T" & i).Value = Sheets("Summary").Range("H4").Value
            .Range("S" & i).Value = "0"
        End If
        If Cells(i, 6).Value <> "" Then
            .Range("Y" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Data!$E$4:$E$15"
            .Cells(i, "X") = "=IFERROR(VLOOKUP(Y" & i & ",Data!$E$4:$F$15,2,FALSE),"""")"
            .Range("Y" & i).Value = "Not Started"
            .Range("T" & i).Value = Sheets("Summary").Range("H4").Value
            .Range("S" & i).Value = "0"
        End If
        If Cells(i, 7).Value <> "" Then
            .Range("Y" & i).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Data!$B$15:$B$16"
            .Cells(i, "X") = "=IFERROR(VLOOKUP(Y" & i & ",Data!$B$15:$C$16,2,FALSE),"""")"
            .Range("Y" & i).Value = "To Be Started"
            .Range("T" & i).Value = "Checker"
            .Range("S" & i).Value = "0"
        End If
    Next i
    
Range("A2").Select
End With
Application.ScreenUpdating = True
Reset_Form
Sheets("Task Entry Form").Select
Range("D3").Select
End Sub

'clear form
Sub Reset_Form()
Application.ScreenUpdating = False
Sheets("Task Entry Form").Select
Range("D3").ClearContents
Range("D5:D22").ClearContents
Range("E5:E22").ClearContents
Range("J5:J22").ClearContents
Range("K5:K22").ClearContents
End Sub

编辑：

这是文件中唯一的其他 VBA，在他们提交给跟踪器之前填写的选项卡上。

    Option Explicit

'copies drawings from data tab based upon dropdown selection

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Address(0, 0) <> "D3" Then Exit Sub
    Application.ScreenUpdating = False
    Dim fnd As Range, LastRow As Long
    [D5:E22,I5:J22].ClearContents
    If Target.Value <> "" Then
        With Sheets("data")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            Set fnd = .Range("L:L").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                With .Range("M" & fnd.Row & ":M" & LastRow).SpecialCells(xlCellTypeConstants)
                    .Areas(1).Resize(, 2).Copy
                    Range("D5").PasteSpecial xlPasteValues
                    With Sheets("data").Range("O" & fnd.Row & ":O" & LastRow).SpecialCells(xlCellTypeConstants)
                        .Areas(1).Resize(, 2).Copy
                    End With
                    Range("I5").PasteSpecial xlPasteValues
                End With
            End If
        End With
    End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

标签： excelvba

解决方案

请使用下一个函数，能够检查分析范围的第二列中是否没有空的对应单元格：

Function compareCols(rng As Range) As String
    Dim rngC1 As Range, cel As Range, i As Long
    If rng.Rows.Count = 1 Then
        If rng.Cells(1, 1) <> "" And rng.Cells(1, 2) = "" Then
            compareCols = "No correspondent data in " & rng.Cells(1, 2).Address: Exit Function
        Else
            compareCols = "OK": Exit Function
        End If
    End If
    Set rngC1 = rng.Columns(1).SpecialCells(xlCellTypeConstants)

    For Each cel In rngC1.Cells
         If cel.Value <> "" And cel.Offset(0, 1) = "" Then
            compareCols = "No correspondent data in " & cel.Offset(0, 1).Address: Exit Function
         End If
    Next cel
    compareCols = "OK"
End Function

在复制之前调用它会完成检查工作，正如（我理解）你需要的那样。

您应该在上面插入此代码行If Model.Rows.Count > 1...：

'your existing code
  Dim strOK As String
  strOK = compareCols(Model)
  If strOK <> "OK" Then MsgBox strOK: Exit Sub
  
  strOK = "": strOK = compareCols(Drawing)
  If strOK <> "OK" Then MsgBox strOK: Exit Sub
  If Model.Rows.Count > 1 Then
    'your existing code...
    '...
 'your existing code

编辑：

请测试您改编的代码，因为它应该......当然没有测试：

Sub CAD_Task_Entry()
 Dim InstalDesc As String, Model As Range, Drawing As Range, Index As Long, m As Long, n As Long

 Application.ScreenUpdating = False
 'Copy data from the input screen to the task list.
 Sheets("Task Entry Form").Select
 InstalDesc = Range("D3")
 Set Model = Range("D5", cells(rows.count, "D").End(xlUp)).Resize(, 2)
 Set Drawing = Range("I5", cells(rows.count, "I").End(xlUp)).Resize(, 2)

 Index = Range("Q2")
 With Sheets("Task List")
    'get first row
    n = .Range("D:X").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
    If n = 3 Then n = 4 Else n = n + 2
    
    'color first row
    .Range("A" & n & ":Z" & n).Interior.color = 15189684
    .cells(n, "D") = InstalDesc & " Summary"
    
    'new code part____________________________
    Dim strOK As String
    strOK = compareCols(Model)
    If strOK <> "OK" Then MsgBox strOK: Exit Sub
  
    strOK = "": strOK = compareCols(Drawing)
    If strOK <> "OK" Then MsgBox strOK: Exit Sub
    'end new code part________________________
    
    If Model.rows.count > 1 Then
        Model.Columns(1).SpecialCells(xlCellTypeConstants).Copy
        .cells(n + 1, "E").PasteSpecial xlPasteValues
        Model.Columns(2).SpecialCells(xlCellTypeConstants).Copy
        .cells(n + 1, "Q").PasteSpecial xlPasteValues
   Else
        Model.Columns(1).Copy
        .cells(n + 1, "E").PasteSpecial xlPasteValues
        Model.Columns(2).Copy
        .cells(n + 1, "Q").PasteSpecial xlPasteValues
  End If
  If Drawing.rows.count > 1 Then
        Drawing.Columns(1).SpecialCells(xlCellTypeConstants).Copy
        .cells(n + Model.rows.count + 1, "F").PasteSpecial xlPasteValues
        Drawing.Columns(2).SpecialCells(xlCellTypeConstants).Copy
        .cells(n + Model.rows.count + 1, "Q").PasteSpecial xlPasteValues
  Else
        Drawing.Columns(1).Copy
        .cells(n + Model.rows.count + 1, "F").PasteSpecial xlPasteValues
        Drawing.Columns(2).Copy
        .cells(n + Model.rows.count + 1, "Q").PasteSpecial xlPasteValues
  End If

    'get last row after inserting data
    m = .Range("D:X").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
    
 End With
 Application.ScreenUpdating = True
 Reset_Form
 Sheets("Task Entry Form").Select
 Range("D3").Select
End Sub

推荐阅读