• 首页

    • 谁能帮我注释下VBA代码?我不是很懂

    Option Explicit

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim i As Integer
    Dim lastRow As Long
    Dim strTemp As String
    Dim rgs As Range
    Dim rg As Range
    Dim d, Res

    lastRow = Sheet2.Range("A65536").End(xlUp).Row

    On Error Resume Next
    If Target.Column = 1 Then
    Set rgs = Sheet2.Range("A2:A" & lastRow)
    Set d = CreateObject("Scripting.Dictionary")

    For Each rg In rgs
    If Not d.exists(rg.Value) Then
    d.Add rg.Value, rg.Value
    End If
    Next

    Res = d.Items
    Dim arr1()

    For i = 0 To d.Count - 1
    ReDim Preserve arr1(i)
    arr1(i) = Res(i)
    Next

    strTemp = Join(arr1, ",")
    Erase arr1

    With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=strTemp
    End With

    ElseIf Target.Column = 2 Then
    Set rgs = Sheet2.Range("B2:B" & lastRow)
    Set d = CreateObject("Scripting.Dictionary")

    For Each rg In rgs
    If Not d.exists(rg.Value) Then
    If rg.Offset(, -1) = Target.Offset(, -1) Then
    d.Add rg.Value, rg.Value
    End If
    End If
    Next

    Res = d.Items
    Dim arr2()

    For i = 0 To d.Count - 1
    ReDim Preserve arr2(i)
    arr2(i) = Res(i)
    Next

    strTemp = Join(arr2, ",")
    Erase arr2

    With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=strTemp
    End With

    ElseIf Target.Column = 3 Then
    Set rgs = Sheet2.Range("C2:C" & lastRow)
    Set d = CreateObject("Scripting.Dictionary")

    For Each rg In rgs
    If Not d.exists(rg.Value) Then
    If rg.Offset(, -2) = Target.Offset(, -2) Then
    If rg.Offset(, -1) = Target.Offset(, -1) Then
    d.Add rg.Value, rg.Value
    End If
    End If
    End If
    Next

    Res = d.Items
    Dim arr3()

    For i = 0 To d.Count - 1
    ReDim Preserve arr3(i)
    arr3(i) = Res(i)
    Next

    strTemp = Join(arr3, ",")
    Erase arr3

    With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=strTemp
    End With

    Else
    Exit Sub
    End If

    End Sub

    推荐答案   2012-03-14
    Option Explicit '强制定义变量(如果有本句存于开始，则所有变量需定义)
    Private Sub Worksheet_SelectionChange(ByVal Target As Range) '当工作表选区发生改变时执行本程序(固定格式)
    Dim i As Integer '定义变量 i 为 整型值
    Dim lastRow As Long '定义变量 lastRow 为 长整型值
    Dim strTemp As String '定义变量 strTemp 为 字符串
    Dim rgs As Range '定义变量 rgs 为 单元格区域
    Dim rg As Range '定义变量 rg 为 单元格区域
    Dim d, Res '定义变量 d,Res
    lastRow = Sheet2.Range("A65536").End(xlUp).Row ' lastRow= Sheet2的<单元格>区域("A65536" )的<末端>(方向向上 )的行标
    On Error Resume Next '当错误 转到 下一个
    If Target.Column = 1 Then '如果 Target的列标=1 则执行
    Set rgs = Sheet2.Range("A2:A" & lastRow) '设定rgs= Sheet2的<单元格>区域("A2:A" & lastRow)
    Set d = CreateObject("Scripting.Dictionary") '设定d=<创建工程>("Scripting.Dictionary")
    For Each rg In rgs '设定变量范围为每一个rg位于rgs
    If Not d.exists(rg.Value) Then '如果 非 d的存在 rg的值) 则执行
    d.Add rg.Value, rg.Value ' d的添加 rg的值, rg的值
    End If 'If判断过程结束
    Next '下一个
    Res = d.Items 'Res= d的Items
    Dim arr1() '定义变量 arr1()
    For i = 0 To d.Count - 1 '设定变量范围为 i=0到 d的计数值-1
    ReDim Preserve arr1(i) '重定义变量预留的arr1(i)
    arr1(i) = Res(i) 'arr1(i)=Res(i)
    Next '下一个
    strTemp = Join(arr1, ",") 'strTemp=<连接字符串>(arr1,",")
    Erase arr1 '删除arr1
    With Target.Validation '工作于 Target的Validation
    .Delete '<With对象>的删除
    .Add Type:=xlValidateList, Formula1:=strTemp '<With对象>的添加 类型=xlValidateList,公式1=strTemp
    End With 'With语句结束
    ElseIf Target.Column = 2 Then '另外如果 Target的列标=2 则执行
    Set rgs = Sheet2.Range("B2:B" & lastRow) '设定rgs= Sheet2的<单元格>区域("B2:B" & lastRow)
    Set d = CreateObject("Scripting.Dictionary") '设定d=<创建工程>("Scripting.Dictionary")
    For Each rg In rgs '设定变量范围为每一个rg位于rgs
    If Not d.exists(rg.Value) Then '如果 非 d的存在 rg的值) 则执行
    If rg.Offset(, -1) = Target.Offset(, -1) Then '如果 rg的<偏移>(,-1)= Target的<偏移>(,-1) 则执行
    d.Add rg.Value, rg.Value ' d的添加 rg的值, rg的值
    End If 'If判断过程结束
    End If 'If判断过程结束
    Next '下一个
    Res = d.Items 'Res= d的Items
    Dim arr2() '定义变量 arr2()
    For i = 0 To d.Count - 1 '设定变量范围为 i=0到 d的计数值-1
    ReDim Preserve arr2(i) '重定义变量预留的arr2(i)
    arr2(i) = Res(i) 'arr2(i)=Res(i)
    Next '下一个
    strTemp = Join(arr2, ",") 'strTemp=<连接字符串>(arr2,",")
    Erase arr2 '删除arr2
    With Target.Validation '工作于 Target的Validation
    .Delete '<With对象>的删除
    .Add Type:=xlValidateList, Formula1:=strTemp '<With对象>的添加 类型=xlValidateList,公式1=strTemp
    End With 'With语句结束
    ElseIf Target.Column = 3 Then '另外如果 Target的列标=3 则执行
    Set rgs = Sheet2.Range("C2:C" & lastRow) '设定rgs= Sheet2的<单元格>区域("C2:C" & lastRow)
    Set d = CreateObject("Scripting.Dictionary") '设定d=<创建工程>("Scripting.Dictionary")
    For Each rg In rgs '设定变量范围为每一个rg位于rgs
    If Not d.exists(rg.Value) Then '如果 非 d的存在 rg的值) 则执行
    If rg.Offset(, -2) = Target.Offset(, -2) Then '如果 rg的<偏移>(,-2)= Target的<偏移>(,-2) 则执行
    If rg.Offset(, -1) = Target.Offset(, -1) Then '如果 rg的<偏移>(,-1)= Target的<偏移>(,-1) 则执行
    d.Add rg.Value, rg.Value ' d的添加 rg的值, rg的值
    End If 'If判断过程结束
    End If 'If判断过程结束
    End If 'If判断过程结束
    Next '下一个
    Res = d.Items 'Res= d的Items
    Dim arr3() '定义变量 arr3()
    For i = 0 To d.Count - 1 '设定变量范围为 i=0到 d的计数值-1
    ReDim Preserve arr3(i) '重定义变量预留的arr3(i)
    arr3(i) = Res(i) 'arr3(i)=Res(i)
    Next '下一个
    strTemp = Join(arr3, ",") 'strTemp=<连接字符串>(arr3,",")
    Erase arr3 '删除arr3
    With Target.Validation '工作于 Target的Validation
    .Delete '<With对象>的删除
    .Add Type:=xlValidateList, Formula1:=strTemp '<With对象>的添加 类型=xlValidateList,公式1=strTemp
    End With 'With语句结束
    Else '另外
    Exit Sub '退出子程序
    End If 'If判断过程结束
    End Sub '子程序结束
    温馨提示：答案为网友推荐，仅供参考
    其他回答
    第1个回答  2012-03-08
    Option Explicit '强制显式声明所有变量。如果试图使用一个未声明的变量，则会在编译时导致错误。

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim i As Integer
    Dim lastRow As Long
    Dim strTemp As String
    Dim rgs As Range
    Dim rg As Range
    Dim d, Res

    lastRow = Sheet2.Range("A65536").End(xlUp).Row '获得表2的A列有数据的最后一行的行号

    On Error Resume Next '当是程序出现错误，程序仍继续运行下一个语句
    If Target.Column = 1 Then
    Set rgs = Sheet2.Range("A2:A" & lastRow)
    Set d = CreateObject("Scripting.Dictionary")

    For Each rg In rgs
    If Not d.exists(rg.Value) Then
    d.Add rg.Value, rg.Value '向字典对象添加值
    End If
    Next

    Res = d.Items
    Dim arr1()

    For i = 0 To d.Count - 1
    ReDim Preserve arr1(i)
    arr1(i) = Res(i)
    Next

    strTemp = Join(arr1, ",") '把数组的数据用“，”连接起来
    Erase arr1 '清空数组arr1

    With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=strTemp
    End With

    ElseIf Target.Column = 2 Then
    Set rgs = Sheet2.Range("B2:B" & lastRow)
    Set d = CreateObject("Scripting.Dictionary")

    For Each rg In rgs
    If Not d.exists(rg.Value) Then
    If rg.Offset(, -1) = Target.Offset(, -1) Then 'Offset(, -1)第一个参数表上下偏移，第二个表左右偏移，正值则向上、右，负则向下、左
    d.Add rg.Value, rg.Value
    End If
    End If
    Next

    Res = d.Items
    Dim arr2()

    For i = 0 To d.Count - 1
    ReDim Preserve arr2(i)
    arr2(i) = Res(i)
    Next

    strTemp = Join(arr2, ",") '把数组的数据用“，”连接起来
    Erase arr2 '清空数组arr2

    With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=strTemp
    End With

    ElseIf Target.Column = 3 Then
    Set rgs = Sheet2.Range("C2:C" & lastRow)
    Set d = CreateObject("Scripting.Dictionary")

    For Each rg In rgs
    If Not d.exists(rg.Value) Then
    If rg.Offset(, -2) = Target.Offset(, -2) Then
    If rg.Offset(, -1) = Target.Offset(, -1) Then
    d.Add rg.Value, rg.Value
    End If
    End If
    End If
    Next

    Res = d.Items
    Dim arr3()

    For i = 0 To d.Count - 1
    ReDim Preserve arr3(i)
    arr3(i) = Res(i)
    Next

    strTemp = Join(arr3, ",")
    Erase arr3

    With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:=strTemp
    End With

    Else
    Exit Sub
    End If

    End Sub
    有些我也不懂，你在网上查查看吧

    相关了解……

    你可能感兴趣的内容

    大家正在搜

    本站内容来自于网友发表，不代表本站立场，仅表示其个人看法，不对其真实性、正确性、有效性作任何的担保
    相关事宜请发邮件给我们
    © 非常风气网