'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
