1.EXCEL VBA遍布文件夹的操作
关于VBA遍历文件夹主要用的是提供的Application.FileDialo函数来由个人进行自由选择,通过获取选择的文件夹地址之后,通过Dir函数来匹配选取文件夹下的相应的文档。相应的VBA程序代码如下:
Dim sel_Path As String '//定义一个选择的文件夹
Dim MyFile As String '//文件夹中符合条件的文件
'//选取相应的文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择文件夹"
If .Show = -1 Then
sel_Path = .SelectedItems(1) '//所选择的文件夹路径
Else
MsgBox "已取消操作!"
Exit Sub
End If
End With
Dim sel_PathFullName As String '定义一个文件的全路径名称
MyFile = Dir(sel_Path & "\" & "*.csv")
2.关于单元格地址的获取
在写VBA的过程中,对于单元格地址的获取至关重要,它直接决定了能否完成正确的完成相应的操作。获取单元格地址主要有以下几种方法:
2.1 以下几种获取结果如注释所示
F_Max_Range = ActiveCell.Address() '获得单元格的地址,形式为$A$1
F_Max_Range = ActiveCell.Address(0, 0) '获得单元格的地址,形式为A1
F_Max_Range = ActiveCell.Address(0, 1) '获得单元格的地址,形式为$A1
F_Max_Range = ActiveCell.Address(1, 0) '获得单元格的地址,形式为A$1
F_Max_Range = ActiveCell.Address(1, 1) '获得单元格的地址,形式为$A$1
2.2 以变量的形式获取单元格地址
以获取最后一列的最后一个单元格的地址为例:首先需要获取获取最后一列的地址,再得到总的行数,将以上两种结果进行拼接,即得出最后一列的最后一个单元格的地址。相应的关键代码如下:
Num_Col = Wb.Worksheets(2).UsedRange.Columns.count '总的列数
Row_Col = Wb.Worksheets(2).UsedRange.Rows.count '总的行数
Add_Max_Col = Split(Cells(1, Num_Col).Address, "$")(1) '获得最后一列的地址
Range_Add_Max_Col = Add_Max_Col & "1" '最后一列的第一个单元格的地址
Range_Add_Max_Row = Add_Max_Col & Row_Col '最后一列的最后一个单元格的地址
2.3 关于单元格的偏移
单元格偏移主要用到的函数是Offset,如偏移1个和2个单元格的关键代码:
F_Max_Range = ActiveCell.Offset(0, 1).Address(0, 0)
S_Max_Range = ActiveCell.Offset(0, 2).Address(0, 0)
2.4 关于选择多个单元格
选择多个单元格要注意单元格之间的拼接格式,要注意中间的“:”,如对以上F_Max_Range 到 S_Max_Range单元格的选择的关键代码:
Wb.Worksheets(2).Range(F_Max_Range & ":" & S_Max_Range).Select
3.关于复制和粘贴
复制和粘贴极大的简化了我们的工作,VBA的复制主要通过copy函数来实现,粘贴主要通过Paste来实现。要注意复制和粘贴之前 一定要选中所要复制的列。即select。关键代码:
'提取出相应的列到sheet2表中
Dim sel_col As String '定义需要操作的列
sel_col = Workbooks("遍历文件夹中的csv文件(处理带逗号的VBA程序)").Worksheets(1).Range("B2").Value
sel_col = Mid(sel_col, InStr(sel_col, ":") + 1)
Wb.Worksheets(1).Range(sel_col).Select
Selection.Copy
Wb.Sheets.Add After:=ActiveSheet
Wb.Worksheets(2).Select
ActiveSheet.Paste
4 完全代码:
本完全代码实现了遍历相应文件夹下的所有EXCEL(CSV)文件,并复制相应的列到另一个sheet中。另外还有分列、绘图操作。关于EXCEL原文件暂不上传,读者可以根据需要进行相应的简单的修改即可。
'//遍历文件夹部分,并选中相应的csv文件
Dim sel_Path As String '//定义一个选择的文件夹
Dim MyFile As String '//文件夹中符合条件的文件
Dim count As Integer '//一共操作文件的数目
'//选取相应的文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择文件夹"
If .Show = -1 Then
sel_Path = .SelectedItems(1) '//所选择的文件夹路径
Else
MsgBox "已取消操作!"
Exit Sub
End If
End With
'//创建一个新的文件夹用来保存数据处理的结果
On Error Resume Next
Dim Save_Path_Name As String
Save_Path_Name = sel_Path & "\" & "文件处理结果"
VBA.MkDir (sel_Path & "\" & "文件处理结果")
Dim sel_PathFullName As String '定义一个文件的全路径名称
Dim Wb As Workbook '定义一个要操作的工作薄
MyFile = Dir(sel_Path & "\" & "*.csv")
'读入文件夹中的第一个.csv文件
Do While MyFile <> ""
count = count + 1 '记录文件的个数
sel_PathFullName = sel_Path & "\" & MyFile '相应文件夹下的符合条件的csv文件
'sel_PathFullName = Application.GetOpenFilename '自定义文件的路径
Set Wb = Workbooks.Open(sel_PathFullName) '打开所选择的文件
'ActiveWindow.Visible = False 静默打开并不能读取文件
'提取出相应的列到sheet2表中
Dim sel_col As String '定义需要操作的列
sel_col = Workbooks("遍历文件夹中的csv文件(处理带逗号的VBA程序)").Worksheets(1).Range("B2").Value
sel_col = Mid(sel_col, InStr(sel_col, ":") + 1)
Wb.Worksheets(1).Range(sel_col).Select
Selection.Copy
Wb.Sheets.Add After:=ActiveSheet
Wb.Worksheets(2).Select
ActiveSheet.Paste
Dim F_Numcol As Long '第一次复制后数据的列的数目
Dim F_Add_Max_Col As String '第一次复制后最后一列的地址
F_Numcol = Wb.Worksheets(2).UsedRange.Columns.count
'选中最后一列
Wb.Worksheets(2).Columns(F_Numcol).Select
F_Add_Max_Col = Split(Cells(1, F_Numcol).Address, "$")(1) & "1" '获得最后一列的地址
'对列进行分列处理
Selection.TextToColumns Destination:=Range(F_Add_Max_Col), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=True, OtherChar:= _
"[", TrailingMinusNumbers:=True
Dim Num_Col As Long '找出表中的最后一列
Dim Row_Col As Long '找出表中的最后一行
Dim Add_Max_Col As String '最后一列的地址
Dim Range_Add_Max_Col As String '定义最后一列的第一个单元格的地址
Dim Range_Add_Max_Row As String '定义最后一行的第一个单元格的地址
Num_Col = Wb.Worksheets(2).UsedRange.Columns.count '总的列数
Row_Col = Wb.Worksheets(2).UsedRange.Rows.count '总的行数
Add_Max_Col = Split(Cells(1, Num_Col).Address, "$")(1) '获得最后一列的地址
Range_Add_Max_Col = Add_Max_Col & "1" '最后一列的第一个单元格的地址
Range_Add_Max_Row = Add_Max_Col & Row_Col '最后一列的最后一个单元格的地址
'选中最后一列
Wb.Worksheets(2).Columns(Num_Col).Select
'对分列出的最后一列进行分列,从而删除"]"字符
Selection.TextToColumns Destination:=Range(Range_Add_Max_Col), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="]", TrailingMinusNumbers:=True
'获得最后一个单元格右边的一个单元格并给其赋值V1
Wb.Worksheets(2).Range(F_Add_Max_Col).Select
'最后一个单元格右边的一个单元格的地址
Dim F_Max_Range As String
Dim S_Max_Range As String
' F_Max_Range = ActiveCell.Address() '获得单元格的地址,形式为$A$1
' F_Max_Range = ActiveCell.Address(0, 0) '获得单元格的地址,形式为A1
' F_Max_Range = ActiveCell.Address(0, 1) '获得单元格的地址,形式为$A1
' F_Max_Range = ActiveCell.Address(1, 0) '获得单元格的地址,形式为A$1
' F_Max_Range = ActiveCell.Address(1, 1) '获得单元格的地址,形式为$A$1
F_Max_Range = ActiveCell.Offset(0, 1).Address(0, 0)
S_Max_Range = ActiveCell.Offset(0, 2).Address(0, 0)
' F_Max_Range = Split(ActiveCell.Offset(0, 1).Address, "$")(1) & "1"
' S_Max_Range = Split(ActiveCell.Offset(0, 2).Address, "$")(1) & "1"
ActiveCell.Offset(0, 1).Value = "V1"
ActiveCell.Offset(0, 2).Value = "V2"
'给分列之后的数据定义一个标签
Wb.Worksheets(2).Range(F_Max_Range & ":" & S_Max_Range).Select
Selection.AutoFill Destination:=Wb.Worksheets(2).Range(F_Max_Range & ":" & Range_Add_Max_Col), Type:=xlFillDefault
'按时间排序
Wb.Worksheets(2).Sort.SortFields.Clear
Wb.Worksheets(2).Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Wb.Worksheets(2).Sort
.SetRange Range("A2:" & Range_Add_Max_Row)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'添加图表:选中数据源
Wb.Worksheets(2).Range(F_Max_Range).Select
Wb.Worksheets(2).Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
'更改图片的大小
ActiveSheet.Shapes(1).ScaleWidth 1.6, msoFalse, _
msoScaleFromBottomRight
ActiveSheet.Shapes(1).ScaleHeight 1.8, msoFalse, _
msoScaleFromBottomRight
Wb.Worksheets(2).Range("A1").Select
'将文件另存为Excel文件
Dim L As Long
Dim Exc_str As String
L = Len(MyFile) - 3
Exc_str = Save_Path_Name & "\" & Mid(MyFile, 1, L) + "xlsx"
Dim FS As Object
Set FS = CreateObject("Scripting.FileSystemObject")
'//判断文件是否存在
If FS.FileExists(Exc_str) Then
Ans = MsgBox(Mid(MyFile, 1, L) + "xlsx" & "文件已经存在,是否覆盖现有文件", vbYesNo)
If Ans = vbYes Then
Kill Exc_str '//删除存在的文件
ActiveWorkbook.SaveAs Filename:=Exc_str, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End If
Else
ActiveWorkbook.SaveAs Filename:=Exc_str, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End If
Wb.Close SaveChanges:=False '关闭文件
'第二次读入的时候不用写参数
MyFile = Dir
If MyFile = "" Then
MsgBox "一共操作了" & count & " 个csv文件!"
Exit Do '当MyFile为空的时候就说明已经遍历完了,这时退出Do,否则还要运行一遍
End If
Loop
遇见不易,欢迎留言评论,共同学习,共同进步,让工作变得更轻松。