（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