小花鹿学习VBA记录

小花鹿

多关键字排序
下列资料来自本站，放在这里是为了查找方便，谢谢原作者。
Sub NewSort()
    Dim Cn As Object, strSql$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    strSql = "Select * From [数据$B1:H] " _
            & "Order By 合计 asc,工资 desc,奖金 desc,津贴 desc,绩效 desc,补贴 desc" 'asc升序，desc降序
    Range("J2").CopyFromRecordset Cn.Execute(strSql)
    Cn.Close: Set Cn = Nothing
End Sub

（求助）多关键字排序.rar (12.65 KB, 下载次数: 28)

2016-6-6 10:52 上传

点击文件名下载附件

小花鹿

从结构相同的多个WORD文档中提取信息到EXCEL：
Sub test()
Dim myword, thispath, mydoc, s, s1, tm, r&
Set myword = CreateObject("word.application")
myword.Visible = True
thispath = ThisWorkbook.Path & "\"
mydoc = Dir(thispath & "*.doc")
Do While mydoc <> ""
    r = r + 1
    With myword
        .documents.Open thispath & mydoc
        .Selection.Find.MatchWildcards = True
        '查找设区市
        s = "设      区      市": s1 = "^13"
        If .Selection.Find.Execute(s & "*" & s1) Then
            tm = .Selection.Text
            tm = Replace(Replace(Replace(tm, s, ""), " ", ""), Chr(13), "")
            Cells(r + 2, 1) = tm: tm = ""
            .Selection.MoveRight Unit:=1, Count:=1
        End If
        '查找学校行政区划
        s = "学 校 行 政 区 划": s1 = "^13"
        If .Selection.Find.Execute(s & "*" & s1) Then
            tm = .Selection.Text
            tm = Replace(Replace(Replace(tm, s, ""), " ", ""), Chr(13), "")
            Cells(r + 2, 2) = tm: tm = ""
            .Selection.MoveRight Unit:=1, Count:=1
        End If
        '查找工作单位
        s = "工   作   单   位": s1 = "^13"
        If .Selection.Find.Execute(s & "*" & s1) Then
            tm = .Selection.Text
            tm = Replace(Replace(Replace(tm, s, ""), " ", ""), Chr(13), "")
            Cells(r + 2, 3) = tm: tm = ""
            .Selection.MoveRight Unit:=1, Count:=1
        End If
        '查找姓名
        s = "姓             名": s1 = "^13"
        If .Selection.Find.Execute(s & "*" & s1) Then
            tm = .Selection.Text
            tm = Replace(Replace(Replace(tm, s, ""), " ", ""), Chr(13), "")
            Cells(r + 2, 4) = tm: tm = ""
            .Selection.MoveRight Unit:=1, Count:=1
        End If
        '读取表格1
        With .activedocument.Tables(1)
            Cells(r + 2, 5) = Replace(Replace(.cell(1, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 6) = Replace(Replace(.cell(1, 6), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 7) = Replace(Replace(.cell(2, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 8) = Replace(Replace(.cell(2, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 9) = Replace(Replace(.cell(3, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 10) = Replace(Replace(.cell(3, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 11) = "'" & Replace(Replace(.cell(4, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 12) = Replace(Replace(.cell(4, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 13) = Replace(Replace(.cell(5, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 14) = "'" & Replace(Replace(.cell(6, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 15) = Replace(Replace(.cell(6, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 16) = Replace(Replace(.cell(7, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 17) = Replace(Replace(.cell(7, 4), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 18) = Replace(Replace(.cell(8, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 19) = Replace(Replace(.cell(9, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 20) = "'" & Replace(Replace(.cell(10, 2), Chr(7), ""), Chr(13), "")
            Cells(r + 2, 21) = "'" & Replace(Replace(.cell(10, 4), Chr(7), ""), Chr(13), "")
        End With
        '-------------------------------------------------------------
        .documents.Close False
    End With
    mydoc = Dir
Loop
myword.Quit
End Sub
30年荣誉证书 - 副本.rar (56.54 KB, 下载次数: 51)

2016-6-7 19:42 上传

点击文件名下载附件

小花鹿

字典排名次：
Sub test()
Dim r, ar, br, d, i&, j&, n, dk, dk1, s
r = [a65536].End(3).Row
ar = Range("a3:j" & r - 2)
ReDim br(1 To r - 2, 1 To 3)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(ar)
    For j = 4 To UBound(ar, 2)
        n = n + ar(i, j)
    Next j
    br(i, 1) = n
    d(n) = d(n) + 1
    n = 0
Next i
dk = d.Keys
n = 1
For i = 0 To UBound(dk)
    s = Application.Large(dk, i + 1)
    j = d(s)
    d(s) = n
    n = n + j
Next i
For i = 1 To UBound(ar)
    br(i, 2) = d(br(i, 1))
Next i
d.RemoveAll
For i = 1 To UBound(ar)
    If d.Exists(ar(i, 1)) = 0 Then
        Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
    End If
    d(ar(i, 1))(br(i, 1)) = d(ar(i, 1))(br(i, 1)) + 1
Next i
For Each dk1 In d.Keys
    dk = d(dk1).Keys
    n = 1
    For i = 0 To UBound(dk)
        s = Application.Large(dk, i + 1)
        j = d(dk1)(s)
        d(dk1)(s) = n
        n = n + j
    Next i
Next dk1
For i = 1 To UBound(ar)
    br(i, 3) = d(ar(i, 1))(br(i, 1))
Next i
[k3].Resize(UBound(ar), 3) = br
End Sub
字典排名次.rar (25.99 KB, 下载次数: 29)

2016-6-10 10:18 上传

点击文件名下载附件

小花鹿

截图软件，很小，但功能强大：
截图软件.rar (1.03 MB, 下载次数: 62)

2016-6-12 21:30 上传

点击文件名下载附件

小花鹿

以下附件来自本站，放在这里是为了查找方便：
提取ppt文字到word：
提取ppt文字到word.rar (21.36 KB, 下载次数: 33)

2016-6-28 10:38 上传

点击文件名下载附件

小花鹿

excel 数据写入word ，用制表位对齐：
Sub test()
Dim ar, br, i&, j&, d1, d2
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
ReDim br(1 To UBound(ar, 2) - 1)
For j = 1 To UBound(br)
    br(j) = Len(ar(1, j))
Next j
For i = 2 To UBound(ar)
    d1(ar(i, 1)) = d1(ar(i, 1)) & ";" & i
    d2(ar(i, 4)) = d2(ar(i, 4)) & ";" & i
    For j = 1 To UBound(ar, 2) - 1
        If Len(ar(i, j)) > br(j) Then br(j) = Len(ar(i, j))
    Next j
Next i
br(1) = (br(1) + 1) * 10
For i = 2 To UBound(br)
    br(i) = br(i - 1) + br(i) * 10 + 10
Next i
Dim myword, d1k, d1i, s, s1, tm, s2, k&
s = "你园新学期幼儿转入转出情况如下，并附家长联系电话："
s1 = "原幼儿园" & vbTab & "姓  名" & vbTab & "年龄" & vbTab & "转入幼儿园" & vbTab & "转入原因" & vbTab & "家长联系电话"
Set myword = CreateObject("word.application")
myword.Visible = True
d1k = d1.keys: d1i = d1.items
For i = 0 To UBound(d1k)
    With myword
        .documents.Add
        With .Selection
            .Text = d1k(i) & "："
            .Font.Size = 16
            .MoveRight Unit:=1, Count:=1
            .TypeParagraph
            .Text = s
            .Font.Size = 16
            .MoveRight Unit:=1, Count:=1
            .TypeParagraph
            .Text = "转出情况："
            .Font.Size = 11
            .Range.HighlightColorIndex = 16
            .MoveRight Unit:=1, Count:=1
            .TypeParagraph
            For j = 1 To UBound(br) - 1
                .ParagraphFormat.TabStops.Add Position:=br(j)
            Next j
            .Text = s1
            .Font.Size = 10.5
            .Range.HighlightColorIndex = 16
            .MoveRight Unit:=1, Count:=1
            .TypeParagraph
            .Range.HighlightColorIndex = 0
            tm = Split(d1(d1k(i)), ";")
            For j = 1 To UBound(tm)
                s2 = ""
                For k = 1 To UBound(ar, 2) - 1
                    s2 = s2 & vbTab & ar(tm(j), k)
                Next k
                s2 = Mid(s2, 2)
                .Text = s2
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
            Next j
            If d2.exists(d1k(i)) Then
                .TypeParagraph
                .TypeParagraph
                .Text = "转入情况："
                .Font.Size = 10.5
                .Range.HighlightColorIndex = 16
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
                .Text = s1
                .Font.Size = 10.5
                .Range.HighlightColorIndex = 16
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
                .Range.HighlightColorIndex = 0
                tm = Split(d2(d1k(i)), ";")
                For j = 1 To UBound(tm)
                    s2 = ""
                    For k = 1 To UBound(ar, 2) - 1
                        s2 = s2 & vbTab & ar(tm(j), k)
                    Next k
                    s2 = Mid(s2, 2)
                    .Text = s2
                    .MoveRight Unit:=1, Count:=1
                    .TypeParagraph
                Next j
            End If
        End With
        .activedocument.SaveAs ThisWorkbook.Path & "\输出各园文件" & "\" & d1k(i) & ".doc"
        .activedocument.Close
    End With
    If d2.exists(d1k(i)) Then d2.Remove (d1k(i))
Next i
If d2.Count Then
    Dim d2k
    d2k = d2.keys
    For i = 0 To UBound(d2k)
        With myword
            .documents.Add
            With .Selection
                .Text = d2k(i) & "："
                .Font.Size = 16
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
                .Text = s
                .Font.Size = 16
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
                .Text = "转入情况："
                .Font.Size = 11
                .Range.HighlightColorIndex = 16
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
                For j = 1 To UBound(br) - 1
                    .ParagraphFormat.TabStops.Add Position:=br(j)
                Next j
                .Text = s1
                .Font.Size = 10.5
                .Range.HighlightColorIndex = 16
                .MoveRight Unit:=1, Count:=1
                .TypeParagraph
                .Range.HighlightColorIndex = 0
                tm = Split(d2(d2k(i)), ";")
                For j = 1 To UBound(tm)
                    s2 = ""
                    For k = 1 To UBound(ar, 2) - 1
                        s2 = s2 & vbTab & ar(tm(j), k)
                    Next k
                    s2 = Mid(s2, 2)
                    .Text = s2
                    .MoveRight Unit:=1, Count:=1
                    .TypeParagraph
                Next j
            End With
            .activedocument.SaveAs ThisWorkbook.Path & "\输出各园文件" & "\" & d2k(i) & ".doc"
            .activedocument.Close
        End With
    Next i
End If
myword.Quit
End Sub

幼儿园转学测试 - 副本.rar (121.99 KB, 下载次数: 33)

2016-7-1 01:05 上传

点击文件名下载附件

小花鹿

WORD选中段落的行数：
CommandBars("Word Count").Visible = True
CommandBars("Word Count").Controls(2).Execute
R = CommandBars("Word Count").Controls(1).List(6)
CommandBars("Word Count").Visible = False

小花鹿

excel 数据写入word 模板，涉及word 表格和域：
Sub test()
Dim r&, ar, br, cr, d1, d2, d3, i&
r = Sheet3.[d65536].End(3).Row
ar = Sheet3.Range("a1:p" & r)
br = Sheet1.[a1].CurrentRegion
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
For i = 3 To r
    If ar(i, 2) <> "" Then
        d1(ar(i, 2)) = i & "|" & ar(i, 3)
        d2(ar(i, 2)) = ar(i, 12) & "|" & ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 3) & "|" & ar(i, 11)
    End If
Next i
Dim n&
For i = UBound(br) To 1 Step -1
    n = n + 1
    If br(i, 3) = "户主" Then
        d3(br(i, 2)) = i & "|" & n
        n = 0
    End If
Next i
Dim myword, d1k, d2i, j&, tabr, tabc, k&, x, y, m&
Set myword = CreateObject("word.application")
myword.Visible = True
d1k = d1.Keys
For i = 0 To UBound(d1k)
    FileCopy ThisWorkbook.Path & "\农村土地家庭承包合同.doc", ThisWorkbook.Path & "\" & d1k(i) & ".doc"
    With myword
        .Documents.Open ThisWorkbook.Path & "\" & d1k(i) & ".doc"
        d2i = Split(d2(d1k(i)), "|")
        With .ActiveDocument
            For j = 0 To UBound(d2i)
                If Left(d2i(j), 1) = "." Then d2i(j) = "0" & d2i(j)
                .Fields(j + 1).Result.Text = d2i(j)
            Next j
            .Fields(3).Result.Text = Split(d3(d1k(i)), "|")(1)
            tabr = .Tables(1).Rows.Count
            tabc = .Tables(1).Columns.Count
            x = Val(Split(d3(d1k(i)), "|")(0)): y = Val((Split(d3(d1k(i)), "|")(1)))
            'm = 1
            For j = x To x + y - 1
                m = m + 1
                .Tables(1).Cell(((m - 1) Mod (tabr - 1)) + 2, Int((m - 1) / (tabr - 1)) * 3 + 1) = br(j, 2)
                .Tables(1).Cell(((m - 1) Mod (tabr - 1)) + 2, Int((m - 1) / (tabr - 1)) * 3 + 2) = br(j, 4)
                .Tables(1).Cell(((m - 1) Mod (tabr - 1)) + 2, Int((m - 1) / (tabr - 1)) * 3 + 3) = br(j, 5)
            Next j
            m = 2
            x = Val(Split(d1(d1k(i)), "|")(0)): y = Val((Split(d1(d1k(i)), "|")(1)))
            For j = x To x + y - 1
                m = m + 1
                For k = 4 To 6
                    If Left(ar(j, k), 1) = "." Then ar(j, k) = "0" & ar(j, k)
                    .Tables(2).Cell(m, k - 3) = ar(j, k)
                Next k
                .Tables(2).Cell(m, 4) = ar(j, UBound(ar, 2))
                For k = 7 To 10
                    .Tables(2).Cell(m, k - 2) = ar(j, k)
                Next k
                .Tables(2).Cell(m, 9) = ar(j, UBound(ar, 2) - 1)
            Next j
            m = 0
            .Close True
        End With
    End With
Next i
myword.Quit
End Sub
合同生成文件_地力.rar (155.67 KB, 下载次数: 30)

2016-7-2 22:41 上传

点击文件名下载附件

补充内容 (2016-9-16 13:44):
附件：http://club.excelhome.net/thread-1272413-1-1.html

jiminyanyan

小花鹿 发表于 2016-7-2 22:41
excel 数据写入word 模板，涉及word 表格和域：
Sub test()
Dim r&, ar, br, cr, d1, d2, d3, i&

老师，附件有密码，能上个没密码的附件让我也学一下吗？

小花鹿

Sub test() '删除空行
Dim r, r1, s, s1
With ActiveDocument
    For Each r1 In .Tables(1).Range.Cells
        s = r1.Range.Text
        s = Replace(s, Chr(13) & Chr(7), "")
        If s = "" Then
            r1.Range.Select
            Selection.SelectRow
            s1 = Selection.Range.Text
            s1 = Replace(s1, Chr(13) & Chr(7), "")
            If s1 = "" Then
                Selection.Rows.Delete
            End If
        End If
    Next r1
End With
End Sub