‘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
时间: 2024-10-13 09:43:05