自己写的一些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 = 1 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(1)
        .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", 1
         
End With
If dig.Show = -1 Then
FileDir = dig.SelectedItems(1) '"C:\Users\Roman\Desktop\点.xls"

 On Error Resume Next
Set xlApp = GetObject(, "Excel.Application") '判断Excel是否打开
If Err.Number <> 0 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(1)
    n = 1
    Do
    n = n + 1
    Loop Until sh.Cells(n, 1) = ""

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

    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 = 1  '//页宽是一页
        .FitToPagesTall = 1  '//页高是一页
        .PaperSize = xlPaperA4  '//纸张大小，pdf输出至桌面
        .CenterVertically = True
        .CenterHorizontally = True
        .Zoom = 65
        
        
        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/