常用代码归集

jsgj2023

网络售后跟踪进度表
http://club.excelhome.net/forum. ... 113&pid=9288866
Sub Adele()
    Set d = CreateObject("scripting.dictionary")
    With Sheets("售后记录表")
        n = 1
        arr = .Range("a1").CurrentRegion
        For x1 = 2 To UBound(arr)
            If arr(x1, 1) = "" Then arr(x1, 1) = arr(x1 - 1, 1)
        Next
         For x = 2 To UBound(arr)
            If Not d.exists(arr(x, 1)) Then
                d(arr(x, 1)) = Array(arr(x, 2), arr(x, 3), arr(x, 4), arr(x, 14), arr(x, 6), arr(x, 7), arr(x, 8), arr(x, 9), arr(x, 11), arr(x, 12), arr(x, 13), 1)
            Else
                n = n + 1
                k = d(arr(x, 1))
                k(8) = k(8) & "," & arr(x, 11)
                k(9) = k(9) & "," & arr(x, 12)
                k(11) = k(11) & "," & n
                d(arr(x, 1)) = k
            End If
         Next
    End With
    Sheet2.Activate
    s = Range("b5")
    If d.exists(s) Then
        a = d(s): [c5] = a(0): [d5] = a(1): [e5] = a(2): [f5] = a(10): [g5] = a(6)
        s1 = Split(a(11), ","): s2 = Split(a(8), ","): s3 = Split(a(9), ",")
        With Application
            [b12].Resize(UBound(s1) + 1) = .Transpose(s1)
            [d12].Resize(UBound(s2) + 1) = .Transpose(s2)
            [f12].Resize(UBound(s3) + 1) = .Transpose(s3)
        End With
    End If
End Sub

jsgj2023

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r&, x&, k&, n&
    r = Cells(Rows.Count, "aa").End(3).Row
    For y = 2 To r
        A1 = CDate(Cells(y, "y"))
            B1 = CDate(Date)
            s = DateDiff("D", A1, B1)
        If Cells(y, "aa") = "吃饭" Then
                If s < 90 And s > 80 Then
                    Cells(y, 36).Interior.ColorIndex = 6
                ElseIf s >= 90 Then
                    Cells(y, 36).Interior.ColorIndex = 3
                Else
                   Cells(y, 36).Interior.ColorIndex = 2
                End If
        ElseIf Cells(y, "aa") = "睡觉" Then
            If s < 45 And s > 35 Then
                    Cells(y, 36).Interior.ColorIndex = 6
                ElseIf s >= 45 Then
                    Cells(y, 36).Interior.ColorIndex = 3
                Else
                    Cells(y, 36).Interior.ColorIndex = 2
                End If
        ElseIf Cells(y, "aa") = "打豆豆" Then
            If s < 180 And s > 90 Then
                    Cells(y, 36).Interior.ColorIndex = 6
                ElseIf s >= 180 Then
                    Cells(y, 36).Interior.ColorIndex = 3
                Else
                    Cells(y, 36).Interior.ColorIndex = 2
                End If
        End If
    Next
End Sub


Private Sub Workbook_Open()
    Sheet1.Activate
    Dim r&, x&, k&, n&
    r = Cells(Rows.Count, "aa").End(3).Row
    For x = 1 To r
        If Cells(x, 36).Interior.ColorIndex = 3 Then
            k = k + 1
        ElseIf Cells(x, 36).Interior.ColorIndex = 6 Then
            n = n + 1
        End If
    Next
    MsgBox "今天有" & k & "已过期!" & Chr(13) & "今天有" & n & "将要过期!"
End Sub

barlz

非常好、非常需要。

jsgj2023

'如何实现这样的统计汇总
'http://club.excelhome.net/thread-1378306-1-1.html
Sub Adele()
    Dim rowIndex(1 To 11), d As Object, arr
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("test").Range("a1").CurrentRegion
    k = 1
    rowIndex(1) = 1
    For m = 1 To UBound(arr)
        If arr(m, 1) <> arr(n + 1, 1) Then
            k = k + 1
            rowIndex(k) = m
        End If
    Next
    For a = 1 To UBound(rowIndex) - 1
        cha = rowIndex(a + 1) - rowIndex(a)
        If cha >= 13 Then
            For x = 1 To UBound(arr)
                s = arr(x, 4)
                d(s) = d(s) + arr(x, 3)
            Next x
            s1 = d.keys: t1 = d.items
        End If
    Next
    [o1].Resize(UBound(s1) + 1) = Application.Transpose(s1)
    [p1].Resize(UBound(t1) + 1) = Application.Transpose(t1)
End Sub

microyip

把每次给别人的帮助作为笔记记录下来，固然是不错的做法，能方便自己查阅的同时，也方便别人查看。但实际上，别人看你这个贴去找对应的代码，可能比较困难，也无从找起；同时，你个人也可能懒得去翻阅，或者翻阅起来也是困难。
建议：可以弄个小号什么的，分不同贴，以标题形式注明用途。

Mooge88

这个要强烈支持一下

Mooge88

楼主能否把附件都集合在一起啊

擎、天

好东西先留个印记

jsgj2023

Sub Method2()
'引用Microsoft Word 14.0 Object Library
    Dim myWord As New Word.Application
    Dim arr As Variant
    Dim k As Variant
    Dim t As Variant
    Dim myPath As String
    Dim myFile As String
    Dim myName As String
    Dim i As Long
    Dim s As String
    Dim d As Object
    Dim arrSplit As Variant
    Set d = CreateObject("scripting.dictionary") '创建字典对象
    myPath = ThisWorkbook.Path & "\" '本工作簿所在的路径
    myFile = myPath & "空白模板.docx" '模板路径
    arr = Sheet1.[a1].CurrentRegion '源数据装入数组
    For x = 2 To UBound(arr) '从第2开始循环直到数组的上界
        d(arr(x, 1)) = arr(x, 1) & "," & arr(x, 2)
    Next
    k = d.keys '取出字典关键字
    t = d.items '取出字典项值
    With myWord '使用word对象
        .Visible = False '打开word时隐藏
        For i = 0 To d.Count - 1 '按字典关键字的数量从0开始循环
            myName = myPath & "空白模板(" & k(i) & ").docx" '新建word文件,并以关键字命名
            arrSplit = Split(t(i), ",") '按逗号拆分字典项值
            FileCopy myFile, myName '按新的文件名复制模板,形成新word文件
            .Documents.Open myName '打开新建的word文件
             With .ActiveDocument.Tables(1) '使用新建word文件的第1张表
                .Cell(1, 1).Range.Text = "线索来源：" & "《" & arrSplit(0) & "》" '单元格填入对应的信息
                .Cell(1, 2).Range.Text = "接收时间：" & "《" & arrSplit(1) & "》" '同上
             End With
            .ActiveDocument.Close True '关闭word文件且保存
        Next
        .Quit '退出word
    End With
    Set myWord = Nothing '释放内存
    MsgBox "OK"
End Sub

aliCT

留下来学习，谢谢