調用Excel巨集批量處理文件

'1.用戶可以任意選擇文件夾進行遍歷
'2.限定遍歷時僅搜索EXCEL文件（你可以改變文件類型）
'這個程式要先在“引用”下選擇"microsoft scripting runtime"庫文件

Dim ArryFile() As String
Dim nFile As Integer
Sub Filelist()
    Dim fso As New FileSystemObject
    Dim fd As Folder
    Dim strFilePath As String
    Dim FolderSelect As FileDialog
    Set FolderSelect = Application.FileDialog(msoFileDialogFolderPicker)
    With FolderSelect
        If .Show = -1 Then
            strFilePath = .SelectedItems.Item(1) & "\"
        End If
    End With
    Set fd = fso.GetFolder(strFilePath)
    nFile = 0
    searchFile fd
End Sub

Private Function searchFile(ByVal fd As Folder)
    Dim fl As File
    Dim subfd As Folder
    Dim i As Integer
    On Error Resume Next
    
    i = fd.files.Count
         
    ReDim Preserve ArryFile(1 To nFile + i)
    For Each fl In fd.files
        If Right(fl.Name, 4) = "xlsx" Then       '尾碼是xls的用   If Right(fl.Name, 3) = "xls" Then
            nFile = nFile + 1
            ArryFile(nFile) = fl.Path
        End If
    Next
    If fd.SubFolders.Count = 0 Then Exit Function
    For Each subfd In fd.SubFolders
        searchFile subfd
    Next
End Function


//主函數，運行時調用該函數
Sub ttt1()

	Dim xlname, myxl As Object, sh As Object

	Call Filelist

	'Set myxl = CreateObject("Aplication.Excel")

    If nFile > 0 Then
        
       For Each xlname In ArryFile()
            If xlname <> "" Then
			 //打開
             Workbooks.Open Filename:=xlname
             //調用Excel處理函數
             Call Macro3
             //保存，關閉
             ActiveWorkbook.Save
             ActiveWorkbook.Close
            End If
       Next
    End If

	Set myxl = Nothing
End Sub


//Excel處理函數，該段替換成自己的處理過程
Sub Macro3()
'
' Macro3 Macro
'
' 快捷鍵: Ctrl+Shift+C
'
    Range("V3:X3").Select
    ActiveCell.FormulaR1C1 = "/"
    With ActiveCell.Characters(Start:=1, Length:=1).Font
        .Name = "宋體"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("B5:J5").Select
    ActiveCell.FormulaR1C1 = "R種植業  □林業  □畜牧業    □漁業    □其他 "
    With ActiveCell.Characters(Start:=1, Length:=1).Font
        .Name = "Wingdings 2"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=2, Length:=3).Font
        .Name = "宋體"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=5, Length:=2).Font
        .Name = "Wingdings 2"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=7, Length:=3).Font
        .Name = "宋體"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=10, Length:=2).Font
        .Name = "Wingdings 2"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=12, Length:=4).Font
        .Name = "宋體"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=16, Length:=4).Font
        .Name = "Wingdings 2"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=20, Length:=3).Font
        .Name = "宋體"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=23, Length:=4).Font
        .Name = "Wingdings 2"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=27, Length:=3).Font
        .Name = "宋體"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With ActiveCell.Characters(Start:=30, Length:=1).Font
        .Name = "Wingdings 2"
        .FontStyle = "常規"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("O9:P35").Select
    Selection.Copy
    Range("E9:F35").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
End Sub