见证成长历程---我的答疑解难代码汇总

lsc900707

表格自动更新到另一个表
http://club.excelhome.net/thread-1332539-1-1.html
(出处: ExcelHome技术论坛)
代码放sheet1的代码区即可：
Private Sub Worksheet_SelectionChange(ByVal T As Range)
   Dim arr
   arr = [a1].CurrentRegion
     For i = 2 To UBound(arr)
         If arr(i, 2) <> 0 Then k = k + 1
         For j = 1 To UBound(arr, 2)
             arr(k, j) = arr(i, j)
        Next
     Next
     With Sheet2
        .[a4:e5000].ClearContents
        .[a4].Resize(k, UBound(arr, 2)) = arr
     End With
End Sub

lsc900707

隐藏和取消隐藏1到12表
http://club.excelhome.net/thread-1332664-1-1.html
(出处: ExcelHome技术论坛)
Private Sub CommandButton1_Click()
    If Me.CommandButton1.Caption = "隐藏" Then
        For Each sht In Sheets
            If sht.Name <> "原表" And sht.Name <> "总表" Then
                sht.Visible = xlSheetHidden
                 Me.CommandButton1.Caption = "取消隐藏"
            End If
        Next
    Else
        Dim aaa As String
        aaa = InputBox("显示表格需要提供密码，请输入密码：", "取消隐藏")
        If Len(aaa) = 0 Then
            Exit Sub
        End If
        If aaa <> 123 Then
            MsgBox "您输入的密码有误，系统终止！"
            Exit Sub
        End If
        For Each sht In Sheets
            If sht.Name <> "原表" And sht.Name <> "总表" Then
                sht.Visible = xlSheetVisible
                Me.CommandButton1.Caption = "隐藏"
            End If
        Next
    End If
End Sub

lsc900707

请问如何根据数据表生成两个表格
http://club.excelhome.net/thread-1332493-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
    Dim arr
    arr = [A1].CurrentRegion
    ReDim brr(1 To 20000, 1 To 9)
    ReDim crr(1 To 20000, 1 To 4)
    For i = 2 To UBound(arr)
        If arr(i, 2) <> "" Then
            k = k + 1: m = m + 1
            brr(k, 1) = arr(i, 2): brr(k, 2) = arr(i, 3): brr(k, 3) = arr(i, 7)
            If (Len(arr(i, 4)) <> 18) * (Len(arr(i, 4)) <> "") Then
                brr(k, 4) = "港澳台身份证"
            Else
                brr(k, 4) = "居民身份证"
            End If
            brr(k, 5) = arr(i, 4): brr(k, 6) = "父亲": brr(k, 7) = arr(i, 49): brr(k, 8) = arr(i, 50): brr(k, 9) = "是"
            crr(m, 1) = arr(i, 2): crr(m, 2) = arr(i, 4): crr(m, 3) = arr(i, 7): crr(m, 4) = arr(i, 3)
        End If
    Next
    With Sheets("微课掌上通导入")
        .[a3:i20000] = ""
        .Columns("E").NumberFormatLocal = "@"
        .[a3].Resize(k, 9) = brr
    End With
    With Sheets("市安全教育平台导入")
        .[a4:d20000] = ""
        .Columns("B").NumberFormatLocal = "@"
        .[a4].Resize(m, 4) = crr
    End With
End Sub

djyang

谢谢老师帮忙

lsc900707

找出A列中是否重复的，在B列标注出来是或者否
http://club.excelhome.net/thread-1332768-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
    Dim arr, brr(), d
    Set d = CreateObject("scripting.dictionary")
    With ActiveSheet
        arr = .[a1].CurrentRegion
        ReDim brr(1 To UBound(arr), 1 To 1)
        For i = 2 To UBound(arr)
            If d.exists(arr(i, 1)) Then
                d(arr(i, 1)) = d(arr(i, 1)) + 1
            Else
                d(arr(i, 1)) = 1
            End If
        Next
        For i = 2 To UBound(arr)
            j = j + 1
            brr(j, 1) = IIf(d(arr(i, 1)) = 1, "否", "是")
        Next
        .[b2:b5000].ClearContents
        .[b2].Resize(UBound(brr)) = brr
    End With
End Sub

djyang

lsc900707 发表于 2017-3-8 14:10
隐藏和取消隐藏1到12表
http://club.excelhome.net/thread-1332664-1-1.html
(出处: ExcelHome技术论坛)
...

老师这个代码可不可以用Sub AAA()开始啊。

lsc900707

djyang 发表于 2017-3-8 19:03
老师这个代码可不可以用Sub AAA()开始啊。

为什么要改呢?这个不放模板，就放工作表代码区就行，按钮用Activex控件按钮。

lsc900707

统计指定时间范围数量
http://club.excelhome.net/thread-1333271-1-1.html
(出处: ExcelHome技术论坛)
Sub lsc()
    Dim d As Object, arr
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        If #4/1/2017# <= arr(i, 2) And arr(i, 2) <= #5/1/2017# Then
            d(arr(i, 1)) = d(arr(i, 1)) + 1
        Else
            d(arr(i, 1)) = 0
        End If
    Next
    k = d.keys: t = d.items
    [d2:e5000] = ""
    [d2].Resize(d.Count) = Application.Transpose(k)
    [e2].Resize(d.Count) = Application.Transpose(t)
End Sub

lsc900707

单个表汇总问题
http://club.excelhome.net/thread-1333627-1-1.html
(出处: ExcelHome技术论坛)
代码放模块，按钮放sheet2：
Sub lsc() '分类求和
    tms = Timer
    arr = Sheet8.[a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(arr)
        If d(arr(i, 1)) = "" Then
            k = k + 1: d(arr(i, 1)) = k
            brr(k, 1) = arr(i, 1)
        End If
        For j = 2 To UBound(arr, 2)
            brr(d(arr(i, 1)), j) = brr(d(arr(i, 1)), j) + arr(i, j)
        Next
    Next
    [a1].CurrentRegion.Offset(1) = ""
    [a2].Resize(k, UBound(arr, 2)) = brr
    MsgBox Timer - tms
End Sub

djyang

牛逼了大神