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

最新推荐文章于 2024-08-13 08:41:40 发布

原创最新推荐文章于 2024-08-13 08:41:40 发布 · 1.1w 阅读

49 ·

CC 4.0 BY-SA版权

EXCEL VBA 专栏收录该内容

4 篇文章

订阅专栏

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

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