VBA初学3----实战(VBA实现Excel转csv)

(VBA实现Excel转csv)

初步学习了VBA相关的知识后,解决了一个需求:

要求读取指定xlsx文件中的指定sheet页,将该sheet页的内容转换为csv文件。

实现的布局如下所示:

文章目录

①实现从指定行开始全数据转换为csv

1、Select-File 按钮功能实现

Select-File 按钮主要是实现选取文件,并将选取文件路径显示到下方。

bash 复制代码
Private Sub CommandButton1_Click()
    Dim filePath As String
    
    filePath = SelectFile()
    
    If filePath <> "" Then
        TextBox1.Text = filePath
    Else
        TextBox1.Text = "Please select file丅"
    End If
End Sub

Public Function SelectFile(Optional title As String = "Select File") As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .title = title
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "all file", "*.*"
        
        If .Show = -1 Then
            SelectFile = .SelectedItems(1)
        Else
            SelectFile = ""
        End If
    End With
End Function

2、Output-File 按钮功能实现

Output-File 按钮功能:读取选取文件的指定sheet页,将对应内容转换为csv文件进行保存,并将保存文件的路径显示在下方。

bash 复制代码
Private Sub CommandButton3_Click()
    On Error GoTo ErrorHandler
    Dim sourceFilePath As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim savePath As String
    Dim fso As Object
    Dim ts As Object
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim csvContent As String
    Dim dataArr() As Variant
    Dim startRow As Long
    Dim fileName As String, folderPath As String
    Dim timeStamp As String
    Dim targetCols As Variant
    Dim colIndex As Variant
    Dim colCounter As Long
    Dim tempArr As Variant
    Dim rowData As Variant
    
    targetCols = Array(1, 3, 5, 6, 7)
    Dim colCount As Long
    colCount = UBound(targetCols) - LBound(targetCols) + 1
    
    startRow = 4
    sourceFilePath = Trim(TextBox1.Text)
    If sourceFilePath = "" Then
        MsgBox "Please select the file丅", vbExclamation
        Exit Sub
    End If
    
   
    If Dir(sourceFilePath) = "" Then
        MsgBox "File does not exit, please select again", vbCritical
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    fileName = "Test11111.csv"
    fileExt = fso.GetExtensionName(sourceFilePath)
    folderPath = fso.GetParentFolderName(sourceFilePath)
    savePath = folderPath & "\" & fileName
    TextBox2.Text = savePath
    If Dir(savePath) <> "" Then
        If MsgBox("The file already exists, do you want to overwrite it?", vbQuestion + vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = False
    Set wbSource = Workbooks.Open(sourceFilePath, ReadOnly:=True)
    Set wsSource = wbSource.Sheets("Sheet1")
    
    With wsSource
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        actualLastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).Column
        maxCol = Application.Max(targetCols)
        
        If lastRow < startRow Then
            MsgBox "Data does not exits丅", vbExclamation
            GoTo CleanUp
        End If
        
        tempArr = .Range(.Cells(startRow, 1), .Cells(lastRow, maxCol)).Value
        
        Dim rowCount As Long
        rowCount = UBound(tempArr, 1)
        
        ReDim dataArr(1 To rowCount, 1 To colCount)
        
        For i = 1 To rowCount
            colCounter = 1
            For Each colIndex In targetCols
                If colIndex <= UBound(tempArr, 2) Then
                    dataArr(i, colCounter) = tempArr(i, colIndex)
                Else
                    dataArr(i, colCounter) = ""
                End If
                colCounter = colCounter + 1
            Next colIndex
        Next i
    End With
    
    Set ts = fso.CreateTextFile(savePath, True, False)
    For i = 1 To UBound(dataArr, 1)
        csvContent = ""
        For j = 1 To UBound(dataArr, 2)
            csvContent = csvContent & CleanCSVValue(dataArr(i, j))
            If j < UBound(dataArr, 2) Then csvContent = csvContent & ","
        Next j
        ts.WriteLine csvContent
    Next i
    ts.Close
    MsgBox "CSV file:" & vbCrLf & savePath, vbInformation, "has outputed"
CleanUp:
    If Not wbSource Is Nothing Then
        wbSource.Close SaveChanges:=False
        Set wbSource = Nothing
    End If
    Set ts = Nothing
    Set fso = Nothing
    Set wsSource = Nothing
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler:
    MsgBox "Error happend" & Err.Description, vbCritical, "ERROR"
    Resume CleanUp
End Sub
Private Function CleanCSVValue(ByVal inputValue As Variant) As String
    If IsEmpty(inputValue) Or IsNull(inputValue) Then
        CleanCSVValue = ""
        Exit Function
    End If
    
    Dim result As String
    result = CStr(inputValue)

    If InStr(result, ",") > 0 Or InStr(result, """") > 0 Or InStr(result, vbCr) > 0 Or InStr(result, vbLf) > 0 Then
        result = Replace(result, """", """""")
        result = """" & result & """"
    End If
    
    CleanCSVValue = result
End Function

3、Clear 按钮功能实现

Clear 按钮主要是将下方两个文件路径清空。

bash 复制代码
Private Sub CommandButton2_Click()
    TextBox1.Text = ""
    TextBox2.Text = ""
End Sub

实现的效果如图所示:

②实现指定行指定列部分数据转换为csv

1、Select-File 按钮功能实现
3、Clear 按钮功能实现

这两个按钮的实现和①一致,没有区别,关键不同点在于转换部分。
2、Output-File 按钮功能实现

Output-File 按钮功能:读取选取文件的指定sheet页,将 指定的列对应内容转换为csv文件进行保存,并将保存文件的路径显示在下方。

bash 复制代码
Private Sub CommandButton3_Click()
    On Error GoTo ErrorHandler
    Dim sourceFilePath As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim savePath As String
    Dim fso As Object
    Dim ts As Object
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim csvContent As String
    Dim dataArr() As Variant
    Dim startRow As Long
    Dim fileName As String, folderPath As String
    Dim timeStamp As String
    Dim targetCols As Variant
    Dim colIndex As Variant
    Dim colCounter As Long
    Dim tempArr As Variant
    Dim rowData As Variant
    
    targetCols = Array(1, 3, 5, 6, 7)
    Dim colCount As Long
    colCount = UBound(targetCols) - LBound(targetCols) + 1
    
    startRow = 4
    sourceFilePath = Trim(TextBox1.Text)
    If sourceFilePath = "" Then
        MsgBox "请选择文件。", vbExclamation
        Exit Sub
    End If
    
   
    If Dir(sourceFilePath) = "" Then
        MsgBox "文件不存在,请重新选择。", vbCritical
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    fileName = "11111.csv"
    fileExt = fso.GetExtensionName(sourceFilePath)
    folderPath = fso.GetParentFolderName(sourceFilePath)
    savePath = folderPath & "\" & fileName
    TextBox2.Text = savePath
    If Dir(savePath) <> "" Then
        If MsgBox("文件已存在,是否覆盖", vbQuestion + vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    Application.ScreenUpdating = False
    Set wbSource = Workbooks.Open(sourceFilePath, ReadOnly:=True)
    Set wsSource = wbSource.Sheets("Sheet1")
    
    With wsSource
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        actualLastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).Column
        maxCol = Application.Max(targetCols)
        
        If lastRow < startRow Then
            MsgBox "文件没有数据", vbExclamation
            GoTo CleanUp
        End If
        
        tempArr = .Range(.Cells(startRow, 1), .Cells(lastRow, maxCol)).Value
        
        Dim rowCount As Long
        rowCount = UBound(tempArr, 1)
        
        ReDim dataArr(1 To rowCount, 1 To colCount)
        
        For i = 1 To rowCount
            colCounter = 1
            For Each colIndex In targetCols
                If colIndex <= UBound(tempArr, 2) Then
                    dataArr(i, colCounter) = tempArr(i, colIndex)
                Else
                    dataArr(i, colCounter) = ""
                End If
                colCounter = colCounter + 1
            Next colIndex
        Next i
    End With
    
    Set ts = fso.CreateTextFile(savePath, True, False)
    For i = 1 To UBound(dataArr, 1)
        csvContent = ""
        For j = 1 To UBound(dataArr, 2)
            csvContent = csvContent & CleanCSVValue(dataArr(i, j))
            If j < UBound(dataArr, 2) Then csvContent = csvContent & ","
        Next j
        ts.WriteLine csvContent
    Next i
    ts.Close
    MsgBox "CSV文件:" & vbCrLf & savePath, vbInformation, "转换完成"
CleanUp:
    If Not wbSource Is Nothing Then
        wbSource.Close SaveChanges:=False
        Set wbSource = Nothing
    End If
    Set ts = Nothing
    Set fso = Nothing
    Set wsSource = Nothing
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler:
    MsgBox "错误发生" & Err.Description, vbCritical, "ERROR"
    Resume CleanUp
End Sub
Private Function CleanCSVValue(ByVal inputValue As Variant) As String
    If IsEmpty(inputValue) Or IsNull(inputValue) Then
        CleanCSVValue = ""
        Exit Function
    End If
    
    Dim result As String
    result = CStr(inputValue)

    If InStr(result, ",") > 0 Or InStr(result, """") > 0 Or InStr(result, vbCr) > 0 Or InStr(result, vbLf) > 0 Then
        result = Replace(result, """", """""")
        result = """" & result & """"
    End If
    
    CleanCSVValue = result
End Function
相关推荐
想学习java初学者5 小时前
SpringBoot整合Fastexcel/EasyExcel导出Excel导出单个图片
excel
LAM LAB11 小时前
【WPS】office邮件合并,怎么将数据源excel中的下一条拼接在文档中的下一个位置
excel·wps
SEO-狼术14 小时前
Document Solutions for Excel, .NET
excel
Access开发易登软件2 天前
Access开发一键删除Excel指定工作表
服务器·前端·后端·excel·vba·access·access开发
Saggitarxm2 天前
Golang实现 - 实现只有表头的 Excel 模板,并在指定列添加了下拉框功能。生成的 Excel 文件在打开时,指定列的单元格会显示下拉选项
excel·下拉框选项序列·生成excel模板·下拉框选项
pk_xz1234562 天前
SAP全自动化工具开发:Excel自动上传与邮件通知系统
运维·人工智能·windows·深度学习·分类·自动化·excel
俊昭喜喜里3 天前
Excel——设置打印的区域
excel
开开心心就好3 天前
Excel数据合并工具:零门槛快速整理
运维·服务器·前端·智能手机·pdf·bash·excel
CodeCraft Studio3 天前
Aspose.Cells 应用案例:法国能源企业实现能源数据报告Excel自动化
自动化·excel·能源·aspose·aspose.cells·数据报告
人工智能训练师3 天前
将EXCEL或者CSV转换为键值对形式的Markdown文件
人工智能·excel