常用代码归集

weiyingde

赞一个，值得拥有

jsgj2023

Sub 从word文档中提取数据()
On Error Resume Next
Dim wdapp As Word.Application
Dim wddoc As Document
Set wdapp = New Word.Application
wdapp.Documents.Open Filename:=ThisWorkbook.Path & "\DEMO\9-4.demo.docx"
With wdapp.Documents(1).Tables(1).Range
    For i = 1 To .Cells.Count
        u = Left(.Cells(i).Range, Len(.Cells(i).Range) - 1)
        If IsNumeric(u) Then
             n = n + 1
             Cells(n + 1, 2) = u
             Cells(n + 1, 1) = Left(.Cells(i - 1).Range, Len(.Cells(i - 1).Range) - 1)
         End If
    Next
End With
    Cells(1, 1) = "姓名"
    Cells(1, 2) = "分数"
wdapp.Quit
End Sub

jsgj2023

Sub 从word文字中提取数据()
Dim wdapp As Word.Application
Set wdapp = New Word.Application
wdapp.Documents.Open ThisWorkbook.Path & "\DEMO\9-5.demo.docx"
With wdapp
c = .Documents(1).Range
    Set regx = CreateObject("vbscript.regexp")
        With regx
            .Global = True
            .Pattern = "\d+、\S+。"
            Set Mat = .Execute(c)
            For Each m In Mat
                n = n + 1
                Cells(n, 1) = m.Value
            Next
        End With
End With
wdapp.Quit
End Sub

jsgj2023

Sub 提取excel数据到word()
For i = 1 To 4
    j = Application.CountIf([a:a], i & "车间")
    Dim wdapp As Word.Application
    Set wdapp = New Word.Application
    With wdapp
        .Documents.Add
        .Visible = True
        .Documents(1).Tables.Add .Selection.Range, j, 5
        .Documents(1).Tables(1).Style = "网格型"
        For Each Rng In Range("a2:a18")
            If Rng.Value = i & "车间" Then
                arr = Rng.EntireRow.Range("a1:e1")
                For Each ar In arr
                    n = n + 1
                    .Documents(1).Tables(1).Range.Cells(n).Range = ar
                Next
            End If
        Next
        n = 0
        .Documents(1).SaveAs ThisWorkbook.Path & "\Adele\9-6\" & i & "车间.docx"
    End With
Next i
End Sub

jsgj2023

'自定义函数_提取不重复值
Function 不重复值(rng As Range)
Set d = CreateObject("scripting.dictionary")
For Each rn In rng
    d(rn.Value) = ""
Next
不重复值 = d.keys
End Function
Function 不重复2(rng As Range, Optional num As Integer = 0)
Set d = CreateObject("scripting.dictionary")
Set regx = CreateObject("vbscript.regexp")
With regx
        .Global = True
    If num = 0 Then
        .Pattern = ".+" '所有值的不重复
    ElseIf num = 1 Then
        .Pattern = "[一-龢]+" '汉字不重复
    ElseIf num = 2 Then
        .Pattern = "[a-zA-Z]+" '字母不重复
    ElseIf num = 3 Then
        .Pattern = "\d+" '数字不重复
    End If
For Each rn In rng
    For Each m In .Execute(rn)
        d(m.Value) = ""
    Next
Next
不重复2 = d.keys
End With
End Function

jsgj2023

'自定义函数_反转字符
Function DD(rng As Range)
For i = Len(rng) To 1 Step -1
    a = Mid(rng, i, 1)
    b = b & a
Next
    DD = b
End Function

jsgj2023

'自定义函数_求和
Function 求和(rng As Range, Optional s As String = "")
Application.Volatile
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "\d" & s
   Set mat = .Execute(rng)
End With
For Each m In mat
n = n + m * 1
Next
求和 = n
End Function

jsgj2023

'自定义函数_按单元格颜色求和
Function COLORSUM(单元格区域 As range, 汇总的颜色 As range)
Set d = CreateObject("Scripting.Dictionary")
For Each Rng In 汇总的颜色
    d(Rng.Interior.ColorIndex) = ""
Next
For Each ci In d.keys
    For Each Rng In 单元格区域
        If Rng.Interior.ColorIndex = ci Then
            r = r + Rng.Value
        End If
    Next
    Next
COLORSUM = r
End Function
Sub test()
Set d = CreateObject("Scripting.Dictionary")
Set 区域 = Application.InputBox("区域选择", , , , , , , 8)
Set 颜色 = Application.InputBox("颜色选择", , , , , , , 8)
For Each Rng In 颜色
    d(Rng.Interior.ColorIndex) = ""
Next
For Each ci In d.keys
    For Each Rng In 区域
        If Rng.Interior.ColorIndex = ci Then
            r = r + Rng.Value
        End If
    Next
    Next
MsgBox r

End Sub

jsgj2023

'自定义函数_身份证信息提取
Function idCard(rng As Range, Optional Key As String = "年龄")
    If Key = "年龄" Then
        idCard = Year(Now()) - (19 & Mid(rng, Len(rng) / 2, 2))
    ElseIf Key = "性别" Then
        idCard = IIf(Mid(rng, 15, 3) Mod 2, "男", "女")
    End If
End Function

jsgj2023

Dim wdapp As Word.Application
Sub 如何往word表中写入数据()
Dim wdapp As Word.Application
Dim wddoc As Document
Set wdapp = New Word.Application
wdapp.Documents.Open Filename:=ThisWorkbook.Path & "\Adele\9-3.demo.docx"
wdapp.Visible = True
With wdapp.Documents(1).Tables(1).Range
    For i = 1 To .Cells.Count
        .Cells(i).Range = i
    Next
End With
With wdapp.Documents(1).Tables(2).Range
    For i = 1 To .Cells.Count
        .Cells(i).Range = "与Adele第" & i & "次见面!"
    Next i
End With
End Sub