excel - 将数据添加到新工作表

Question

我有一个数据验证列表值，我的宏会根据这个值将数据复制到工作簿中的特定位置。但是，当从数据验证列表中选择一个值时，宏会跳过 IF 语句，就好像该语句为假一样。你能帮我理解为什么会这样吗？如果我删除数据验证，宏将按预期工作。谢谢!

Sub AddToList()
    
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lRow1 As Long
    Dim lRow2 As Long
    Dim lRow3 As Long
    Dim lRow4 As Long
    
    Application.ScreenUpdating = False
    
    Set ws1 = ThisWorkbook.Worksheets("DILUTION CALCULATOR")
    Set ws2 = ThisWorkbook.Worksheets("SETUP")
    
    lRow1 = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    lRow2 = ws2.Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
    lRow3 = ws2.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Row
    lRow4 = ws2.Cells(Rows.Count, 13).End(xlUp).Offset(1, 0).Row
    
    If ws1.Range("M4") = "" Or ws1.Range("O4") = "" Or ws1.Range("Q4") = "" Then
        MsgBox "Please Enter Data In All Fields", vbCritical
        Exit Sub
    ElseIf ws1.Range("M4") = "Customer" Then
        ws1.Range("O4 , Q4").Copy
        ws2.Cells(lRow1, 1).PasteSpecial Paste:=xlValues
    ElseIf ws1.Range("M4") = "Order Number" Then
        ws1.Range("O4 , Q4").Copy
        ws2.Cells(lRow2, 5).PasteSpecial Paste:=xlValues
    ElseIf ws1.Range("M4") = "Quantity" Then
        ws1.Range("O4 , Q4").Copy
        ws2.Cells(lRow3, 9).PasteSpecial Paste:=xlValues
    ElseIf ws1.Range("M4") = "Status" Then
        ws1.Range("O4 , Q4").Copy
        ws2.Cells(lRow4, 13).PasteSpecial Paste:=xlValues
    End If
    
    ws1.Range("M4, O4, Q4").ClearContents
    
    Application.ScreenUpdating = True
    
End Sub

Answer 1

复制到另一个工作表

Option Explicit

Sub AddToList()

    Const sName As String = "DILUTION CALCULATOR"
    Const srgAddress As String = "M4,O4,Q4" ' at least two cells
    
    Const dName As String = "SETUP"
    ' Both arrays have to have the same number of elements.
    Dim dCols As Variant: dCols = VBA.Array(1, 5, 9, 13)
    Dim Criteria As Variant
    Criteria = VBA.Array("Customer", "Order Number", "Quantity", "Status")
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(srgAddress)
    Dim cCount As Long: cCount = srg.Cells.Count
    
    Dim sCell As Range
    
    For Each sCell In srg.Cells
        If Len(CStr(sCell.Value)) = 0 Then
            MsgBox "Please enter data in all fields.", vbCritical
            Exit Sub
        End If
    Next sCell
    
    Dim cIndex As Variant
    cIndex = Application.Match(CStr(srg.Cells(1).Value), Criteria, 0)
    
    If IsError(cIndex) Then
        MsgBox "Criteria not found.", vbCritical
        Exit Sub
    End If
        
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drg As Range: Set drg = dws.Cells(dws.Rows.Count, dCols(cIndex - 1)) _
        .End(xlUp).Offset(1).Resize(, cCount - 1)
    
    Dim dc As Long
    
    For Each sCell In srg.Cells
        If dc > 0 Then
            drg.Cells(dc).Value = sCell.Value
        End If
        dc = dc + 1
    Next sCell
    
    srg.ClearContents
    
End Sub