请帮忙修改，程序无法运行。谢谢～～

bachelorme

http://115.com/file/dpkln575  附件



Function isYesNo(thisName$) As Boolean
    Dim ts

    Set ts = CreateObject("Wscript.shell")
    isYesNo = ts.popup(thisName & " 更新完毕,是否继续！", 2, "提示(3秒钟自动关闭)！", vbYesNo)

End Function



Sub Macro1()
    Application.Visible = False
    Application.ScreenUpdating = False
    Dim AA As String
    Dim BB As String
    Dim i&, ii&
    Dim w As Integer
    Dim yc As Integer
   
    Dim A   '对应的行号
    Dim B   '行号所对应的产品名
    Dim C   '考察值的位置
    Dim D   '与上面相应的位置所要的色
    Dim Rng
    A = "158,313,468,623,775, 933,1088,1243,1398,1553,1678,1803, 1958,2113, 2304,2471,2638,2805,2822,2839"
    A = Split(Replace(A, " ", ""), ",")
   
    B = "JL0015,JL0016,JL0005,JL0006,JL0008,JL0026,JL0007,   JL0022,JL0025,JL0021,H1179,H1180,JL0027,JL0028,JL0029,JL0030,JL0031,JL0032,JL0051,JL0053"
    B = Split(Replace(B, " ", ""), ",")
   
    C = "148,135, 134, 125, 124, 115, 114, 105, 94, 93, 66, 65, 50, 49, 16"
    C = Split(Replace(C, " ", ""), ",")

    D = "15773696,5287936, 65280 ,10498160,12611584,1968238,2509346,10079487 ,16776960,13083058,4659950,7816902,255,49407, 5296274  "
    D = Split(Replace(D, " ", ""), ",")
   
   
    ReDim Rng(LBound(C) To UBound(C)) As Range   '建一个数组记录每个考察值所对应的单元
   
    Dim TheRng As Range
    Dim thisRng As Range


    For i = 1804 To 2839

        For ii = LBound(A) To UBound(A)
            If i = Val(A(ii)) Then
                If isYesNo(CStr(B(ii))) = False Then Exit For
            End If
        Next
        
        
        
        '不用总selec什么的,会很慢
        With Sheets(1)
            AA = .Cells(i, 2).Value
            BB = .Cells(i, 3).Value

            For ii = LBound(C) To UBound(D)
                If .Cells(i, Val(C(ii))) <> "" Then
                    Set thisRng = Sheets(AA).Cells.Find(What:=BB)
                    Set Rng(ii) = Union(thisRng, Rng(ii))
                End If
            Next

            If .Cells(i, 16).Value = "" And .Cells(i, 47).Value = "" Then
                Set thisRng = Sheets(AA).Cells.Find(What:=BB).Activate
                Set TheRng = Union(thisRng, TheRng)
            End If
        End With
    Next
   
    For i = LBound(Rng) To UBound(Rng)
        '一次性赋值
        If Not Rng(i) Is Nothing Then Rng(i).Interior.Color = CLng(Val(D(i)))           '分段吊装颜色
    Next
   
    If Not TheRng Is Nothing Then
        With TheRng.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End If

    Application.Visible = True
    Application.ScreenUpdating = True

   
    w = MsgBox("状态表更新完毕，是否需要保存？", vbOKCancel, "提示")
    If w = vbOK Then
   
        ActiveWorkbook.Save
        MsgBox "文件已经保存！"
    ElseIf w = vbCancel Then
        Application.Visible = True
    End If
End Sub

shuyee

你的附件下不到,显示"拥有者未分享".
没有数据,不方便测试错在何处.

bachelorme

shuyee 发表于 2012-5-18 10:29
你的附件下不到,显示"拥有者未分享".
没有数据,不方便测试错在何处.

http://115.com/file/dpkln575#
这个地址。。。

bachelorme

http://115.com/file/dpkln575#这个是下载地址，之前那个地址不对。。

shuyee

前2个按钮的宏映射存在错误，找不到执行的过程。第3个钮按的宏，有密码，无法查看代码