调用Excel宏批量处理文件

Posted 2020-08-08 Lzm

 

‘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