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

发布于:2025-07-06 ⋅ 阅读:(17) ⋅ 点赞:(0)

(VBA实现Excel转csv)
初步学习了VBA相关的知识后,解决了一个需求:
要求读取指定xlsx文件中的指定sheet页,将该sheet页的内容转换为csv文件。
实现的布局如下所示:
在这里插入图片描述

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

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

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文件进行保存,并将保存文件的路径显示在下方。

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 按钮主要是将下方两个文件路径清空。

Private Sub CommandButton2_Click()
    TextBox1.Text = ""
    TextBox2.Text = ""
End Sub

实现的效果如图所示:
在这里插入图片描述

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

1、Select-File 按钮功能实现
3、Clear 按钮功能实现
这两个按钮的实现和①一致,没有区别,关键不同点在于转换部分。
2、Output-File 按钮功能实现
Output-File 按钮功能:读取选取文件的指定sheet页,将 指定的列对应内容转换为csv文件进行保存,并将保存文件的路径显示在下方。

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