Excel - Export table / Pivot to CSV directly
Attribute VB_Name = "modExportSelectedTableToCsv"
' Module: modExportSelectedTableToCsv
Option Explicit
Public Sub ExportSelectedTableOrPivotToCsv()
Dim sourceWorkbook As Workbook
Dim sourceWorksheet As Worksheet
Dim selectedTable As ListObject
Dim selectedPivot As pivotTable
Dim pivotExportRange As Range
Dim objectName As String
Dim csvPath As String
Dim exportAllRows As Boolean
Dim promptResult As VbMsgBoxResult
Dim filteredOrHidden As Boolean
Dim isPivotFiltered As Boolean
If ActiveCell Is Nothing Then
MsgBox "Select a cell inside an Excel Table or PivotTable first.", _
vbExclamation, _
"Export CSV"
Exit Sub
End If
Set sourceWorksheet = ActiveCell.Worksheet
Set sourceWorkbook = sourceWorksheet.Parent
If Len(sourceWorkbook.Path) = 0 Then
MsgBox "Save the workbook before exporting." & vbCrLf & vbCrLf & _
"The CSV will be created in the workbook's folder.", _
vbExclamation, _
"Export CSV"
Exit Sub
End If
Set selectedTable = GetTableFromCell(ActiveCell)
If selectedTable Is Nothing Then
Set selectedPivot = GetPivotTableFromCell(ActiveCell)
End If
If selectedTable Is Nothing And selectedPivot Is Nothing Then
MsgBox "The selected cell is not inside an Excel Table or PivotTable.", _
vbExclamation, _
"Export CSV"
Exit Sub
End If
If Not selectedTable Is Nothing Then
objectName = selectedTable.Name
filteredOrHidden = _
ListObjectHasActiveFilter(selectedTable) Or _
RangeHasHiddenRows(selectedTable.DataBodyRange)
Else
objectName = selectedPivot.Name
Set pivotExportRange = GetPivotExportRange(selectedPivot)
If pivotExportRange Is Nothing Then
Exit Sub
End If
isPivotFiltered = PivotTableHasFilters(selectedPivot)
filteredOrHidden = _
isPivotFiltered Or _
RangeHasHiddenRows(pivotExportRange)
End If
csvPath = sourceWorkbook.Path & _
Application.PathSeparator & _
SanitizeFileName(objectName) & ".csv"
If filteredOrHidden Then
If Not selectedPivot Is Nothing And isPivotFiltered Then
promptResult = MsgBox( _
"Filtered or hidden PivotTable data was detected." & _
vbCrLf & vbCrLf & _
"YES = Export ALL rendered PivotTable rows" & vbCrLf & _
"NO = Export VISIBLE worksheet rows only" & vbCrLf & _
"CANCEL = Do not export" & vbCrLf & vbCrLf & _
"Pivot field and slicer filters remain applied.", _
vbYesNoCancel + vbQuestion, _
"Export " & objectName)
Else
promptResult = MsgBox( _
"Filtered or hidden rows were detected." & _
vbCrLf & vbCrLf & _
"YES = Export ALL rows" & vbCrLf & _
"NO = Export VISIBLE rows only" & vbCrLf & _
"CANCEL = Do not export", _
vbYesNoCancel + vbQuestion, _
"Export " & objectName)
End If
If promptResult = vbCancel Then
Exit Sub
End If
exportAllRows = (promptResult = vbYes)
Else
exportAllRows = True
End If
If FileExists(csvPath) Then
promptResult = MsgBox( _
"The CSV already exists:" & vbCrLf & vbCrLf & _
csvPath & vbCrLf & vbCrLf & _
"Overwrite it?", _
vbYesNo + vbQuestion, _
"Overwrite CSV")
If promptResult <> vbYes Then
Exit Sub
End If
End If
On Error GoTo ExportError
If FileExists(csvPath) Then
Kill csvPath
End If
If Not selectedTable Is Nothing Then
ExportListObjectCsv _
table:=selectedTable, _
filePath:=csvPath, _
exportAllRows:=exportAllRows
Else
ExportPivotTableCsv _
pivotRange:=pivotExportRange, _
filePath:=csvPath, _
exportAllRows:=exportAllRows
End If
MsgBox "CSV exported successfully:" & _
vbCrLf & vbCrLf & _
csvPath, _
vbInformation, _
"Export Complete"
Exit Sub
ExportError:
MsgBox "The CSV could not be exported." & _
vbCrLf & vbCrLf & _
"Error " & err.Number & ": " & err.Description, _
vbCritical, _
"Export CSV"
End Sub
Private Function GetPivotExportRange( _
ByVal pivotTable As pivotTable) As Range
Dim promptResult As VbMsgBoxResult
Dim filterRowCount As Long
If PivotHasReportFilterRows(pivotTable) Then
filterRowCount = _
pivotTable.TableRange1.Row - _
pivotTable.TableRange2.Row
promptResult = MsgBox( _
"This PivotTable has " & filterRowCount & _
" report-filter row(s) above the Pivot headers." & _
vbCrLf & vbCrLf & _
"Strip those filter rows from the CSV?" & _
vbCrLf & vbCrLf & _
"YES = Start at the Pivot headers" & vbCrLf & _
" Include headers, data, subtotals and totals" & vbCrLf & _
"NO = Include the report-filter rows" & vbCrLf & _
"CANCEL = Do not export", _
vbYesNoCancel + vbQuestion, _
"PivotTable Export Range")
Select Case promptResult
Case vbYes
Set GetPivotExportRange = pivotTable.TableRange1
Case vbNo
Set GetPivotExportRange = pivotTable.TableRange2
Case Else
Set GetPivotExportRange = Nothing
End Select
Else
Set GetPivotExportRange = pivotTable.TableRange1
End If
End Function
Private Function PivotHasReportFilterRows( _
ByVal pivotTable As pivotTable) As Boolean
On Error GoTo NoFilterRows
PivotHasReportFilterRows = _
pivotTable.TableRange2.Row < pivotTable.TableRange1.Row
Exit Function
NoFilterRows:
PivotHasReportFilterRows = False
End Function
Private Function GetTableFromCell( _
ByVal targetCell As Range) As ListObject
On Error Resume Next
Set GetTableFromCell = targetCell.ListObject
On Error GoTo 0
End Function
Private Function GetPivotTableFromCell( _
ByVal targetCell As Range) As pivotTable
On Error Resume Next
Set GetPivotTableFromCell = targetCell.pivotTable
On Error GoTo 0
End Function
Private Sub ExportListObjectCsv( _
ByVal table As ListObject, _
ByVal filePath As String, _
ByVal exportAllRows As Boolean)
Dim fileNumber As Integer
Dim dataRow As Range
Dim errorNumber As Long
Dim errorDescription As String
On Error GoTo CleanFail
fileNumber = FreeFile
Open filePath For Binary Access Write As #fileNumber
WriteUtf8Bom fileNumber
If table.ShowHeaders Then
If Not table.HeaderRowRange Is Nothing Then
WriteCsvRow fileNumber, table.HeaderRowRange
End If
End If
If Not table.DataBodyRange Is Nothing Then
For Each dataRow In table.DataBodyRange.Rows
If exportAllRows Or Not dataRow.EntireRow.Hidden Then
WriteCsvRow fileNumber, dataRow
End If
Next dataRow
End If
If table.ShowTotals Then
If Not table.TotalsRowRange Is Nothing Then
If exportAllRows Or _
Not table.TotalsRowRange.EntireRow.Hidden Then
WriteCsvRow fileNumber, table.TotalsRowRange
End If
End If
End If
Close #fileNumber
Exit Sub
CleanFail:
errorNumber = err.Number
errorDescription = err.Description
On Error Resume Next
If fileNumber > 0 Then
Close #fileNumber
End If
On Error GoTo 0
err.Raise _
errorNumber, _
"ExportListObjectCsv", _
errorDescription
End Sub
Private Sub ExportPivotTableCsv( _
ByVal pivotRange As Range, _
ByVal filePath As String, _
ByVal exportAllRows As Boolean)
Dim fileNumber As Integer
Dim pivotRow As Range
Dim errorNumber As Long
Dim errorDescription As String
On Error GoTo CleanFail
fileNumber = FreeFile
Open filePath For Binary Access Write As #fileNumber
WriteUtf8Bom fileNumber
For Each pivotRow In pivotRange.Rows
If exportAllRows Or Not pivotRow.EntireRow.Hidden Then
WriteCsvRow fileNumber, pivotRow
End If
Next pivotRow
Close #fileNumber
Exit Sub
CleanFail:
errorNumber = err.Number
errorDescription = err.Description
On Error Resume Next
If fileNumber > 0 Then
Close #fileNumber
End If
On Error GoTo 0
err.Raise _
errorNumber, _
"ExportPivotTableCsv", _
errorDescription
End Sub
Private Sub WriteCsvRow( _
ByVal fileNumber As Integer, _
ByVal sourceRow As Range)
Dim sourceCell As Range
Dim csvLine As String
Dim columnIndex As Long
For columnIndex = 1 To sourceRow.Columns.count
Set sourceCell = sourceRow.Cells(1, columnIndex)
If columnIndex > 1 Then
csvLine = csvLine & ","
End If
csvLine = _
csvLine & _
CsvEscape(GetCellExportText(sourceCell))
Next columnIndex
WriteUtf8Text fileNumber, csvLine & vbCrLf
End Sub
Private Function GetCellExportText( _
ByVal sourceCell As Range) As String
Dim displayedText As String
If IsError(sourceCell.value) Then
GetCellExportText = sourceCell.text
Exit Function
End If
If IsEmpty(sourceCell.value) Then
GetCellExportText = vbNullString
Exit Function
End If
displayedText = CStr(sourceCell.text)
If InStr(1, displayedText, "###", vbBinaryCompare) = 0 Then
GetCellExportText = displayedText
Else
GetCellExportText = CStr(sourceCell.Value2)
End If
End Function
Private Function CsvEscape( _
ByVal value As String) As String
CsvEscape = _
"""" & _
Replace(value, """", """""") & _
""""
End Function
Private Function ListObjectHasActiveFilter( _
ByVal table As ListObject) As Boolean
Dim filterIndex As Long
On Error GoTo NoFilter
If table.AutoFilter Is Nothing Then
Exit Function
End If
For filterIndex = 1 To table.AutoFilter.Filters.count
If table.AutoFilter.Filters(filterIndex).On Then
ListObjectHasActiveFilter = True
Exit Function
End If
Next filterIndex
NoFilter:
End Function
Private Function PivotTableHasFilters( _
ByVal pivotTable As pivotTable) As Boolean
Dim pivotField As pivotField
For Each pivotField In pivotTable.PivotFields
On Error Resume Next
err.Clear
If pivotField.PivotFilters.count > 0 Then
PivotTableHasFilters = True
On Error GoTo 0
Exit Function
End If
err.Clear
If Not pivotField.AllItemsVisible Then
PivotTableHasFilters = True
On Error GoTo 0
Exit Function
End If
On Error GoTo 0
Next pivotField
End Function
Private Function RangeHasHiddenRows( _
ByVal sourceRange As Range) As Boolean
Dim sourceRow As Range
If sourceRange Is Nothing Then
Exit Function
End If
For Each sourceRow In sourceRange.Rows
If sourceRow.EntireRow.Hidden Then
RangeHasHiddenRows = True
Exit Function
End If
Next sourceRow
End Function
Private Function SanitizeFileName( _
ByVal fileName As String) As String
Dim invalidCharacters As Variant
Dim invalidCharacter As Variant
invalidCharacters = _
Array("\", "/", ":", "*", "?", """", "<", ">", "|")
fileName = Trim$(fileName)
For Each invalidCharacter In invalidCharacters
fileName = _
Replace( _
fileName, _
CStr(invalidCharacter), _
"_")
Next invalidCharacter
Do While Len(fileName) > 0 And _
(Right$(fileName, 1) = "." Or _
Right$(fileName, 1) = " ")
fileName = _
Left$(fileName, Len(fileName) - 1)
Loop
If Len(fileName) = 0 Then
fileName = "Export"
End If
SanitizeFileName = fileName
End Function
Private Function FileExists( _
ByVal filePath As String) As Boolean
On Error Resume Next
FileExists = _
(Len(Dir$( _
filePath, _
vbNormal Or vbHidden Or vbSystem)) > 0)
On Error GoTo 0
End Function
Private Sub WriteUtf8Bom( _
ByVal fileNumber As Integer)
Dim bom(0 To 2) As Byte
bom(0) = &HEF
bom(1) = &HBB
bom(2) = &HBF
Put #fileNumber, , bom
End Sub
Private Sub WriteUtf8Text( _
ByVal fileNumber As Integer, _
ByVal text As String)
Dim utf8Bytes() As Byte
If Len(text) = 0 Then
Exit Sub
End If
utf8Bytes = StringToUtf8Bytes(text)
Put #fileNumber, , utf8Bytes
End Sub
Private Function StringToUtf8Bytes( _
ByVal text As String) As Byte()
Dim output() As Byte
Dim textIndex As Long
Dim outputIndex As Long
Dim codeUnit As Long
Dim nextCodeUnit As Long
Dim codePoint As Long
ReDim output(0 To (Len(text) * 4) - 1)
textIndex = 1
Do While textIndex <= Len(text)
codeUnit = _
AscW(Mid$(text, textIndex, 1))
If codeUnit < 0 Then
codeUnit = codeUnit + 65536
End If
If codeUnit >= &HD800 And _
codeUnit <= &HDBFF And _
textIndex < Len(text) Then
nextCodeUnit = _
AscW(Mid$(text, textIndex + 1, 1))
If nextCodeUnit < 0 Then
nextCodeUnit = nextCodeUnit + 65536
End If
If nextCodeUnit >= &HDC00 And _
nextCodeUnit <= &HDFFF Then
codePoint = _
&H10000 + _
((codeUnit - &HD800) * &H400) + _
(nextCodeUnit - &HDC00)
textIndex = textIndex + 1
Else
codePoint = codeUnit
End If
Else
codePoint = codeUnit
End If
Select Case codePoint
Case 0 To &H7F
output(outputIndex) = codePoint
outputIndex = outputIndex + 1
Case 0 To &H7FF
output(outputIndex) = _
&HC0 Or (codePoint \ &H40)
output(outputIndex + 1) = _
&H80 Or (codePoint And &H3F)
outputIndex = outputIndex + 2
Case 0 To &HFFFF
output(outputIndex) = _
&HE0 Or (codePoint \ &H1000)
output(outputIndex + 1) = _
&H80 Or _
((codePoint \ &H40) And &H3F)
output(outputIndex + 2) = _
&H80 Or _
(codePoint And &H3F)
outputIndex = outputIndex + 3
Case Else
output(outputIndex) = _
&HF0 Or (codePoint \ &H40000)
output(outputIndex + 1) = _
&H80 Or _
((codePoint \ &H1000) And &H3F)
output(outputIndex + 2) = _
&H80 Or _
((codePoint \ &H40) And &H3F)
output(outputIndex + 3) = _
&H80 Or _
(codePoint And &H3F)
outputIndex = outputIndex + 4
End Select
textIndex = textIndex + 1
Loop
ReDim Preserve output(0 To outputIndex - 1)
StringToUtf8Bytes = output
End Function
Comments
Post a Comment