常用代码归集

jsgj2023

Sub 创建和保存word文档()
    Dim res
    Dim docApp As Object
    Application.StatusBar = "创建新的Word文档......"
    Set docApp = CreateObject("Word.Application")
    With docApp
        .Visible = True
        Application.StatusBar = "创建新的Word文档..."
        .Documents.Add
        .ActiveDocument.Paragraphs(1).Range.InsertBefore "Excel VBA实用操作技巧"
        .Application.StatusBar = "保存文档......"
        .ActiveDocument.SaveAs ThisWorkbook.Path & "\Excel VBA实用操作技巧.doc"
        Application.StatusBar = "退出新建的Word文档..."
        res = MsgBox("已经创建了Word文档，是否要关闭Word文档？", vbYesNo)
        If res = vbYes Then
            .Quit
        End If
    End With
    Set docApp = Nothing
    Application.StatusBar = False
End Sub

jsgj2023

Sub 打开指定的word文档()
    Dim myFile As String
    Dim docApp As Word.Application
    myFile = ThisWorkbook.Path & "\Excel VBA实用操作技巧.doc"
    Set docApp = New Word.Application
    With docApp
        .Documents.Open myFile
        .Visible = True
    End With
    Set docApp = Nothing
End Sub

jsgj2023

Sub 打开指定的word文档_创建对象()
    Dim myFile As String
    Dim docApp As Object
    '指定要打开的Word文档
    myFile = ThisWorkbook.Path & "\Excel VBA实用操作技巧.doc"
    Set docApp = CreateObject("Word.Application")
    With docApp
        .Documents.Open myFile
        .Visible = True
    End With
    Set docApp = Nothing
End Sub

jsgj2023

Sub 复制word文档第4行以下的数据到表格()
Dim myfile As String
Dim docapp As Word.Application
Dim docrange  As Word.Range
Dim ws  As Worksheet
myfile = ThisWorkbook.Path & "\操作说明.doc"
Set docapp = New Word.Application
docapp.Documents.Open myfile
With docapp.ActiveDocument
    If .Paragraphs.Count >= 4 Then
        Set docrange = .Paragraphs(4).Range
        docrange.Copy
    End If
End With
ws.Range("a1").Activate
ws.Paste
docapp.Quit
Set docrange = Nothing
Set docapp = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub 创建ppt文档()
Dim pptapp As PowerPoint.Application
Dim pptprs As PowerPoint.Presentation
Dim myppt As String
Dim res
myppt = ThisWorkbook.Path & "\PowerPoint1.ppt"
Set pptapp = New PowerPoint.Application
pptapp.Visible = True
Set pptprs = pptapp.Presentations.Add
With pptprs
    With .Slides.Add(Index:=1, Layout:=ppLayoutText).Shapes
        .Title.TextFrame.TextRange = "这是PowerPoint试验标题"
        .Range(2).TextFrame.TextRange = "这是PowerPoint试验正文"
    End With
    res = MsgBox("已经创建PowerPoint文档,是否要保存并关闭?", vbYesNo)
    If res = vbYes Then
        .SaveAs myppt
        .Close
        pptapp.Quit
    End If
End With
Set pptprs = Nothing
Set pptapp = Nothing
End Sub

wenjun8216

来仔细看看楼主写的文章，

jsgj2023

Sub 打开指定的ppt文档()
    Dim pptApp As PowerPoint.Application
    Dim pptPrs As PowerPoint.Presentation
    Dim myppt As String
    myppt = ThisWorkbook.Path & "\Adele.ppt"
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPrs = pptApp.Presentations.Open(myppt)
    Set pptPrs = Nothing
    Set pptApp = Nothing
End Sub

jsgj2023

Sub 电话号码添加分隔符()
arr = Sheets("通讯录").Range("a1").CurrentRegion
For x = 2 To UBound(arr)
    For y = 1 To UBound(arr, 2)
        If IsNumeric(arr(x, y)) Then
            s = arr(x, y)
            s1 = Mid(s, 1, 3)
            s2 = Mid(s, 4, 4)
            s3 = Mid(s, 8, 4)
            arr(x, y) = s1 & "-" & s2 & "-" & s3
        End If
    Next y
Next x
[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
Cells.EntireColumn.AutoFit
End Sub

jsgj2023

Sub 根据表格内容创建PPT文档()
    Dim ws As Worksheet
    Dim pptApp As PowerPoint.Application
    Dim pptPrs As PowerPoint.Presentation
    Dim i As Long
    Dim myppt As String
    myppt = ThisWorkbook.Path & "\PowerPoint试验.ppt"
    Set ws = Worksheets(1)
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPrs = pptApp.Presentations.Add
    With pptPrs
        For i = 1 To 5
            With .Slides.Add(Index:=i, Layout:=ppLayoutText).Shapes
                .Title.TextFrame.TextRange = ws.Cells(i, 1).Text     '添加标题
                .Range(2).TextFrame.TextRange = ws.Cells(i + 1, 2).Text _
                    & vbCrLf & ws.Cells(i + 1, 3).Text _
                    & vbCrLf & ws.Cells(i + 1, 4).Text        '添加正文
            End With
        Next i
        .SaveAs myppt
'        .Close         '设置此语句可关闭创建的文档
    End With
'    pptApp.Quit       '设置此语句可关闭PowerPoint应用程序
    Set ws = Nothing
    Set pptPrs = Nothing
    Set pptApp = Nothing
End Sub

wangdaxiao

谢谢楼主分享