拉伸试验查询表中的VBA编程中出现的问题求助

1007885996

现因工作需要，使用EXCEL 2007的VBA 编程文件编制了拉伸试验查询表，现发现部分标准的第一行查询数据无，其余均正确；现苦思不得其解，请各位前辈给予指导，十分感谢！



Sub BiaoZhun()
    On Error Resume Next
    Dim x, Arr1, D1, L1
    Set D1 = CreateObject("scripting.dictionary")
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    D1.comparemode = vbTextCompare
    With Sheets("拉伸试验原始数据")
        Arr1 = .Range("a1").CurrentRegion
        For x = 2 To UBound(Arr1)
            D1(Arr1(x, 1)) = ""
        Next x
    End With
    L1 = Join(Application.Transpose(Application.Transpose(D1.KEYS)), ",")
    Range("B1:b3").Validation.Delete
    Range("b2:b3").ClearContents
    Range("B1").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=L1
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Sub PaiHao()
    On Error Resume Next
    Application.EnableEvents = False
    If Range("b1") <> "" Then
        Application.ScreenUpdating = False
        Dim x, Arr1, D1, Up, Ed
        Set D1 = CreateObject("scripting.dictionary")
        D1.comparemode = vbTextCompare
        With Sheets("拉伸试验原始数据")
            Arr1 = .Range("a1").CurrentRegion
            Up = .Range("a:a").Find(Range("b1"), , , xlWhole).Row
            Ed = .Range("a:a").Find(Range("b1"), , , xlWhole, , xlPrevious).Row
            For x = Up To Ed
                If Arr1(x, 1) = Range("b1") Then
                    D1(Arr1(x, 2)) = ""
                End If
            Next x
        End With
        Range("B2:b3").Validation.Delete
        Range("b3").ClearContents
        If D1.Count > 0 Then
            L1 = Join(Application.Transpose(Application.Transpose(D1.KEYS)), ",")
            Range("B2").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=L1
        End If
        Application.ScreenUpdating = True
    End If
    Application.EnableEvents = True
End Sub
Sub GuiGe()
    On Error Resume Next
    Application.EnableEvents = False
    If Range("b1") <> "" And Range("b2") <> "" Then
        Application.ScreenUpdating = False
        Dim x, Arr1, D1, Up, Ed
        Set D1 = CreateObject("scripting.dictionary")
        D1.comparemode = vbTextCompare
        With Sheets("拉伸试验原始数据")
            Arr1 = .Range("a1").CurrentRegion
            Up = .Range("a:a").Find(Range("b1"), , , xlWhole).Row
            Ed = .Range("a:a").Find(Range("b1"), , , xlWhole, , xlPrevious).Row
            For x = Up To Ed
                If Arr1(x, 1) = Range("b1") And Arr1(x, 2) = Range("b2") And Arr1(x, 3) <> "" Then
                    D1(Arr1(x, 3)) = ""
                End If
            Next x
        End With
        Range("B3").Validation.Delete
        If D1.Count > 0 Then
            Range("b3") = "选择规格"
            L1 = Join(Application.Transpose(Application.Transpose(D1.KEYS)), ",")
            Range("B3").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=L1
        Else
            Range("b3") = "-"
        End If
        Application.ScreenUpdating = True
    End If
    Application.EnableEvents = True
End Sub

Sub List1()
    On Error Resume Next
    Application.EnableEvents = False
    With Sheets("拉伸试验原始数据")
        Application.ScreenUpdating = False
        Dim x, Y, K, Arr1, Arr2(), D1, Up, Ed
        Arr1 = .Range("a1").CurrentRegion
        ReDim Arr2(1 To UBound(Arr1), 1 To 2)
        Up = .Range("a:a").Find(Range("b1"), , , xlWhole).Row
        Ed = .Range("a:a").Find(Range("b1"), , , xlWhole, , xlPrevious).Row
        For x = Up To Ed
            If Arr1(x, 2) = Range("b2") Then
                For Y = 4 To UBound(Arr1, 2)
                    If Arr1(x, Y) <> "" Then
                        K = K + 1
                        Arr2(K, 1) = Arr1(1, Y)
                        Arr2(K, 2) = Arr1(x, Y)
                    End If
                Next Y
                Exit For
            End If
        Next x
        Range("a6").Resize(10000, 4).ClearContents
        Range("a6").Resize(K, 2) = Arr2
        Application.ScreenUpdating = True
    End With
    Application.EnableEvents = True
End Sub
Sub list2()
    On Error Resume Next
    Application.EnableEvents = False
    With Sheets("拉伸试验原始数据")
        Application.ScreenUpdating = False
        Dim x, Y, K, Arr1, Arr2(), Up, Ed, Up2, Ed2
        Arr1 = .Range("a1").CurrentRegion
        ReDim Arr2(1 To UBound(Arr1), 1 To 2)
        Up = .Range("a:a").Find(Range("b1"), , , xlWhole).Row
        Ed = .Range("a:a").Find(Range("b1"), , , xlWhole, , xlPrevious).Row
        Up2 = .Range(.Cells(Up, 2), .Cells(Ed, 2)).Find(Range("b2"), , , xlWhole).Row
        Ed2 = .Range(.Cells(Up, 2), .Cells(Ed, 2)).Find(Range("b2"), , , xlWhole, , xlPrevious).Row
        For x = Up2 To Ed2
            If Arr1(x, 3) = Range("b3") Then
                For Y = 4 To UBound(Arr1, 2)
                    If Arr1(x, Y) <> "" Then
                        K = K + 1
                        Arr2(K, 1) = Arr1(1, Y)
                        Arr2(K, 2) = Arr1(x, Y)
                    End If
                Next Y
                Exit For
            End If
        Next x
        Range("a6").Resize(10000, 4).ClearContents
        Range("a6").Resize(K, 2) = Arr2
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub



Private Sub Worksheet_Activate()
    Call BiaoZhun
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    If Target.Address = "$B$1" Then
        Call PaiHao
        Call GuiGe
    End If
    If Target.Address = "$B$2" Then
        Call PaiHao
        Call GuiGe
        Range("a6").Resize(10000, 4).ClearContents
        If Range("b3") = "-" Then
            Call List1
        End If
    End If
    If Target.Address = "$B$3" Then
        Range("a6").Resize(10000, 4).ClearContents
        If Range("b3") <> "选择规格" And Range("b3") <> "-" And Range("b3") <> "" Then
            Call list2
        End If
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Application.ScreenUpdating = False
    If Target.Address = "$B$1" Then
        Call PaiHao
        Call GuiGe
    End If
    If Target.Address = "$B$2" Then
'        Call PaiHao
        Call GuiGe
    End If
'    If Target.Address = "$B$3" Then
'        Call GuiGe
'    End If
    Application.ScreenUpdating = True
End Sub

Sub ttt()
    Application.EnableEvents = True

End Sub