I want to be able to export a selected range of cells to a .csv file using VBA. What I have come up with so far does the job excellently for cohering selections, but fails misearably when multiple columns are selected.
Here is the code I managed to put together from snippets found on the internet: It also fiddles around with some UI and since my Excel speaks German and I need to have “.” as decimal separator instead of “,” it tweaks that.
Sub Range_Nach_CSV_() Dim vntFileName As Variant Dim lngFN As Long Dim rngRow As Excel.Range Dim rngCell As Excel.Range Dim strDelimiter As String Dim strText As String Dim strTextCell As String Dim strTextCelll As String Dim bolErsteSpalte As Boolean Dim rngColumn As Excel.Range Dim wksQuelle As Excel.Worksheet Dim continue As Boolean strDelimiter = vbtab continue = True Do While continue = True vntFileName = Application.GetSaveAsFilename("Test.txt", _ FileFilter:="TXT-File (*.TXT),*.txt") If vntFileName = False Then Exit Sub End If If Len(Dir(vntFileName)) > 0 Then Dim ans As Integer ans = MsgBox("Datei existiert bereits. Überschreiben?", vbYesNo) If ans = vbYes Then continue = False ElseIf ans = vbNo Then continue = True Else continue = False End If Else continue = False End If Loop Set wksQuelle = ActiveSheet lngFN = FreeFile Open vntFileName For Output As lngFN For Each rngRow In Selection.Rows strText = "" bolErsteSpalte = True For Each rngCell In rngRow.Columns strTextCelll = rngCell.Text strTextCell = Replace(strTextCelll, ",", ".") If bolErsteSpalte Then strText = strTextCell bolErsteSpalte = False Else strText = strText & strDelimiter & strTextCell End If Next Print #lngFN, strText Next Close lngFN End Sub
As I already mentioned the sub works well with coherent selections and also with multiple selected lines, but fails when it comes to multiple columns.
The current output of the sub can be seen on this here picture:
multiple columns failed
As one would expect, I want the .csv-file (or respective .txt-file) to look like this:
multiple columns desired output
How can I achieve the desired behaviour for the last case?
And would someone be so kind to include the links as images? If perceived appropriate, of course.
This might seem a little complex, but your use case isn’t very simple…
It does assume that each of the selected areas is the same size, and that they all line up (as either rows or columns)
Sub Tester() Dim s As String, srow As String, sep As String Dim a1 As Range, rw As Range, c As Range, rCount As Long Dim areaCount As Long, x As Long Dim bColumnsSelected As Boolean Dim sel As Range bColumnsSelected = False Set sel = Selection areaCount = Selection.Areas.Count Set a1 = Selection.Areas(1) If areaCount > 1 Then If a1.Cells(1).Column <> Selection.Areas(2).Cells(1).Column Then 'areas represent different columns (not different rows) bColumnsSelected = True Set sel = a1 End If End If rCount = 0 For Each rw In sel.Rows rCount = rCount + 1 srow = "" sep = "" For Each c In rw.Cells srow = srow & sep & Replace(c.Text, ",", ".") sep = "," Next c 'if there are multiple areas selected (as columns), then include those If bColumnsSelected Then For x = 2 To areaCount For Each c In Selection.Areas(x).Rows(rCount).Cells srow = srow & sep & Replace(c.Text, ",", ".") Next c Next x End If s = s & IIf(Len(s) > 0, vbCrLf, "") & srow Next rw Debug.Print s End Sub