VBA初学3----实战（VBA实现Excel转csv）

（VBA实现Excel转csv）
初步学习了VBA相关的知识后，解决了一个需求：
要求读取指定xlsx文件中的指定sheet页，将该sheet页的内容转换为csv文件。
实现的布局如下所示：

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

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

Private Sub CommandButton1_Click()Dim filePath As StringfilePath = SelectFile()If filePath <> "" ThenTextBox1.Text = filePathElseTextBox1.Text = "Please select file丅"End If
End SubPublic Function SelectFile(Optional title As String = "Select File") As StringWith Application.FileDialog(msoFileDialogFilePicker).title = title.AllowMultiSelect = False.Filters.Clear.Filters.Add "all file", "*.*"If .Show = -1 ThenSelectFile = .SelectedItems(1)ElseSelectFile = ""End IfEnd With
End Function

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

Private Sub CommandButton3_Click()On Error GoTo ErrorHandlerDim sourceFilePath As StringDim wbSource As WorkbookDim wsSource As WorksheetDim savePath As StringDim fso As ObjectDim ts As ObjectDim lastRow As Long, lastCol As LongDim i As Long, j As LongDim csvContent As StringDim dataArr() As VariantDim startRow As LongDim fileName As String, folderPath As StringDim timeStamp As StringDim targetCols As VariantDim colIndex As VariantDim colCounter As LongDim tempArr As VariantDim rowData As VarianttargetCols = Array(1, 3, 5, 6, 7)Dim colCount As LongcolCount = UBound(targetCols) - LBound(targetCols) + 1startRow = 4sourceFilePath = Trim(TextBox1.Text)If sourceFilePath = "" ThenMsgBox "Please select the file丅", vbExclamationExit SubEnd IfIf Dir(sourceFilePath) = "" ThenMsgBox "File does not exit, please select again", vbCriticalExit SubEnd IfSet fso = CreateObject("Scripting.FileSystemObject")fileName = "Test11111.csv"fileExt = fso.GetExtensionName(sourceFilePath)folderPath = fso.GetParentFolderName(sourceFilePath)savePath = folderPath & "\" & fileNameTextBox2.Text = savePathIf Dir(savePath) <> "" ThenIf MsgBox("The file already exists, do you want to overwrite it?", vbQuestion + vbYesNo) = vbNo ThenExit SubEnd IfEnd IfApplication.ScreenUpdating = FalseSet wbSource = Workbooks.Open(sourceFilePath, ReadOnly:=True)Set wsSource = wbSource.Sheets("Sheet1")With wsSourcelastRow = .Cells(.Rows.Count, 1).End(xlUp).RowactualLastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).ColumnmaxCol = Application.Max(targetCols)If lastRow < startRow ThenMsgBox "Data does not exits丅", vbExclamationGoTo CleanUpEnd IftempArr = .Range(.Cells(startRow, 1), .Cells(lastRow, maxCol)).ValueDim rowCount As LongrowCount = UBound(tempArr, 1)ReDim dataArr(1 To rowCount, 1 To colCount)For i = 1 To rowCountcolCounter = 1For Each colIndex In targetColsIf colIndex <= UBound(tempArr, 2) ThendataArr(i, colCounter) = tempArr(i, colIndex)ElsedataArr(i, colCounter) = ""End IfcolCounter = colCounter + 1Next colIndexNext iEnd WithSet 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 jts.WriteLine csvContentNext its.CloseMsgBox "CSV file:" & vbCrLf & savePath, vbInformation, "has outputed"
CleanUp:If Not wbSource Is Nothing ThenwbSource.Close SaveChanges:=FalseSet wbSource = NothingEnd IfSet ts = NothingSet fso = NothingSet wsSource = NothingApplication.ScreenUpdating = TrueExit SubErrorHandler:MsgBox "Error happend" & Err.Description, vbCritical, "ERROR"Resume CleanUp
End Sub
Private Function CleanCSVValue(ByVal inputValue As Variant) As StringIf IsEmpty(inputValue) Or IsNull(inputValue) ThenCleanCSVValue = ""Exit FunctionEnd IfDim result As Stringresult = CStr(inputValue)If InStr(result, ",") > 0 Or InStr(result, """") > 0 Or InStr(result, vbCr) > 0 Or InStr(result, vbLf) > 0 Thenresult = Replace(result, """", """""")result = """" & result & """"End IfCleanCSVValue = 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 ErrorHandlerDim sourceFilePath As StringDim wbSource As WorkbookDim wsSource As WorksheetDim savePath As StringDim fso As ObjectDim ts As ObjectDim lastRow As Long, lastCol As LongDim i As Long, j As LongDim csvContent As StringDim dataArr() As VariantDim startRow As LongDim fileName As String, folderPath As StringDim timeStamp As StringDim targetCols As VariantDim colIndex As VariantDim colCounter As LongDim tempArr As VariantDim rowData As VarianttargetCols = Array(1, 3, 5, 6, 7)Dim colCount As LongcolCount = UBound(targetCols) - LBound(targetCols) + 1startRow = 4sourceFilePath = Trim(TextBox1.Text)If sourceFilePath = "" ThenMsgBox "请选择文件。", vbExclamationExit SubEnd IfIf Dir(sourceFilePath) = "" ThenMsgBox "文件不存在，请重新选择。", vbCriticalExit SubEnd IfSet fso = CreateObject("Scripting.FileSystemObject")fileName = "11111.csv"fileExt = fso.GetExtensionName(sourceFilePath)folderPath = fso.GetParentFolderName(sourceFilePath)savePath = folderPath & "\" & fileNameTextBox2.Text = savePathIf Dir(savePath) <> "" ThenIf MsgBox("文件已存在，是否覆盖", vbQuestion + vbYesNo) = vbNo ThenExit SubEnd IfEnd IfApplication.ScreenUpdating = FalseSet wbSource = Workbooks.Open(sourceFilePath, ReadOnly:=True)Set wsSource = wbSource.Sheets("Sheet1")With wsSourcelastRow = .Cells(.Rows.Count, 1).End(xlUp).RowactualLastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).ColumnmaxCol = Application.Max(targetCols)If lastRow < startRow ThenMsgBox "文件没有数据", vbExclamationGoTo CleanUpEnd IftempArr = .Range(.Cells(startRow, 1), .Cells(lastRow, maxCol)).ValueDim rowCount As LongrowCount = UBound(tempArr, 1)ReDim dataArr(1 To rowCount, 1 To colCount)For i = 1 To rowCountcolCounter = 1For Each colIndex In targetColsIf colIndex <= UBound(tempArr, 2) ThendataArr(i, colCounter) = tempArr(i, colIndex)ElsedataArr(i, colCounter) = ""End IfcolCounter = colCounter + 1Next colIndexNext iEnd WithSet 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 jts.WriteLine csvContentNext its.CloseMsgBox "CSV文件：" & vbCrLf & savePath, vbInformation, "转换完成"
CleanUp:If Not wbSource Is Nothing ThenwbSource.Close SaveChanges:=FalseSet wbSource = NothingEnd IfSet ts = NothingSet fso = NothingSet wsSource = NothingApplication.ScreenUpdating = TrueExit SubErrorHandler:MsgBox "错误发生" & Err.Description, vbCritical, "ERROR"Resume CleanUp
End Sub
Private Function CleanCSVValue(ByVal inputValue As Variant) As StringIf IsEmpty(inputValue) Or IsNull(inputValue) ThenCleanCSVValue = ""Exit FunctionEnd IfDim result As Stringresult = CStr(inputValue)If InStr(result, ",") > 0 Or InStr(result, """") > 0 Or InStr(result, vbCr) > 0 Or InStr(result, vbLf) > 0 Thenresult = Replace(result, """", """""")result = """" & result & """"End IfCleanCSVValue = result
End Function