关于利用EXCEL VBA 获取单元格地址、选取、复制、分列到其它工作薄中以及遍布文件夹的操作

2023-11-11 01:46| 来源: 网络整理| 查看: 265

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

遇见不易，欢迎留言评论，共同学习，共同进步，让工作变得更轻松。

【本文地址】

公司简介

联系我们