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
相关推荐
Fireworkitte10 小时前
Apache POI 详解 - Java 操作 Excel/Word/PPT
java·apache·excel
红衣女妖仙18 小时前
JXLS 库导出复杂 Excel
java·excel·jxls·java 导出 excel
吃我两拳21 小时前
EasyExcel停止当前Sheet的读取,且不影响主线程及其他Sheet读取的方法
excel
qq_393828221 天前
办公文档批量打印器 Word、PPT、Excel、PDF、图片和文本,它都支持批量打印。
windows·word·powerpoint·excel·软件需求
过期的秋刀鱼!1 天前
用“做饭”理解数据分析流程(Excel三件套实战)
数据挖掘·数据分析·excel·powerbi·数据分析入门
挑战者6668881 天前
如何将Excel表的内容转化为json格式呢?
excel
干净的坏蛋1 天前
EasyExcel实现Excel复杂格式导出:合并单元格与样式设置实战
excel
张太行_11 天前
MySQL与Excel比较
数据库·mysql·excel
cwtlw11 天前
Excel学习03
笔记·学习·其他·excel