自己写的一些Excel及WordVBA函数[原创]

1、将Excel当前工作表另存至桌面

Excel中有时一个工作簿中工作表特别多，需要快速单独存取其中一个，可用以下代码快速存至桌面

Sub 另存工作表到桌面()
   Dim sh As Worksheet
   Set sh = ActiveWorkbook.ActiveSheet
   sh.Copy
   ActiveWorkbook.SaveAs Filename:="C:\Users\Administrator\Desktop\" & sh.Name & ".xlsx"
   ActiveWorkbook.Close
End Sub

 2、word中图片大小批量修改

Sub 全局调整(hight As Double, width As Double)
    Dim n
    For n =  To ActiveDocument.InlineShapes.Count
       With ActiveDocument.InlineShapes(n)
         '.Reset
         .LockAspectRatio = msoFalse
         .Height = hight / 0.0353
         .width = width / 0.0353

       End With
    Next n
    msg = MsgBox("图片调整完成！", , "提示")
End Sub

Sub 单图调整(hight As Double, width As Double)
    With Selection.InlineShapes()
        .LockAspectRatio = msoFalse
        .Height = hight / 0.0353
        .width = width / 0.0353
    End With
End Sub

3、word以excel为数据源进行批量数据替换

新建excel文件，在A列输入被替换的内容，B列输入替换后的内容，然后执行以下代码

Sub 批量替换(replace As Boolean)

Dim dig As Object
      Set dig = Application.FileDialog(msoFileDialogFilePicker)
       With dig
         .InitialFileName = "C:\Users\Roman\Desktop\"
         .Filters.Add "Excel", "*.xls; *.xlsx; *.xlsm", 

End With
If dig.Show = - Then
FileDir = dig.SelectedItems() '"C:\Users\Roman\Desktop\点.xls"

 On Error Resume Next
Set xlApp = GetObject(, "Excel.Application") '判断Excel是否打开
If Err.Number <>  Then
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
xlApp.Visible = False '设置EXCEL对象可见
End If
Err.Clear
Set wk1 = xlApp.Workbooks.Open(FileDir) '打开工件簿文件
wk1.Visible = False '是否显示文件

'批量替换
    Set sh = wk1.Sheets()
    n =
    Do
    n = n +
    Loop Until sh.Cells(n, ) = ""

    For i =  To n
    text1 = sh.Cells(i, )  '替换源
    text2 = sh.Cells(i, )  '替换目标

    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Application.WindowState = wdWindowStateNormal
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = text1
        .Replacement.Text = text2
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute replace:=wdReplaceAll
    Next i
    xlApp.Quit
    msg = MsgBox("替换完成！", , "提示")
  End If

4、将文件夹中的Excel表格批量输出为pdf

Sub outPdf()
    Dim myFile, myPath
    myPath = ""
    myFile = Dir(myPath & "*.xlsx")
    Do While myFile <> ""
        If myFile <> ThisWorkbook.Name Then
            Workbooks.Open (myPath & myFile)

             With ActiveSheet.PageSetup
        .PrintArea = "A1:L15"  '//打印区域
        .FitToPagesWide =   '//页宽是一页
        .FitToPagesTall =   '//页高是一页
        .PaperSize = xlPaperA4  '//纸张大小，pdf输出至桌面
        .CenterVertically = True
        .CenterHorizontally = True
        .Zoom = 

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\Roman\Desktop\" & ActiveSheet.Range("f5") & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        True
    End With

        End If
        myFile = Dir
    Loop
End Sub

-----------------------------------------------------------

转载请注明出处：https://www.cnblogs.com/implementer/