自己寫的一些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/