[接龙...]部分程序代码注释，目录更新20051222

zhusong1998

这是一个从另一个文件中查找相应的内容并直接替换的代码，请求给以注释以方便学习并衍生成其他的代码。

谢谢了。

Sub 查找替换()
    Application.ScreenUpdating = False
    Dim crr(1 To 1000, 1 To 2)
    Set d = CreateObject("scripting.dictionary")
    With GetObject(ThisWorkbook.Path & "\各商品供应商对照表.xlsx")
        arr = .Sheets(1).[a1].CurrentRegion
        .Close False
    End With
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = arr(i, 2)
    Next
    With Sheets("孟加拉")
        Set Rng = .Cells.Find("序号", , , 1)
        If Not Rng Is Nothing Then
            c = Rng.Column + 2
            r = Rng.Row + 2
            cc = .UsedRange.Columns.Count
            rr = .Cells(Rows.Count, cc - 2).End(xlUp).Row
            arr = .Cells(r, c).Resize(rr + 1 - r, cc + 1 - c)
            For i = 1 To UBound(arr)
                For j = 1 To UBound(arr, 2)
                    If Len(arr(i, j)) Then
                        b = Left(arr(i, j), 1)
                        If Not IsNumeric(b) Then
                            If d.exists(arr(i, j)) Then
                                arr(i, j) = d(arr(i, j))
                            Else
                                n = n + 1
                                crr(n, 1) = i
                                crr(n, 2) = j
                            End If
                        End If
                    End If
                Next
            Next
            .Cells(r, c).Resize(UBound(arr), UBound(arr, 2)) = arr
            For i = 1 To n
                .Cells(crr(i, 1) + r - 1, crr(i, 2) + c - 1).Interior.ColorIndex = 3
            Next
        End If
    End With
    Application.ScreenUpdating = True
End Sub

高山雪原

十一年了！陈年佳酿！

hrbxpj

向龙老师致敬

水刀梁

这是个好贴，顶起来

jingchai

收藏学习。

lrh788

学习实用性强！！

身后脚印一串

厉害，新手很收益

yes363001640

太好的帖子，感谢

liuguixu

Long_III 发表于 2005-8-5 16:45
5、类似分组显示数据，代码是Private Sub Worksheet_SelectionChange(ByVal Target As Range)  & ...

大哥，这个只能是A列可以折叠展开，如果多级要怎么办，怎样让B列，C列，D列，E列，F列，G列，都可以像A列那样可以点击折叠展开