将选定的行和列导出到CSV文件

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.

我希望能够使用VBA将选定范围的单元格导出到.csv文件。到目前为止,我所提出的工作能够很好地完成选择,但是当选择多个列时,它会失败。

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.

这是我设法从互联网上找到的片段组合起来的代码:它还摆弄了一些用户界面,因为我的Excel说德语,我需要“。”作为小数分隔符而不是“,”它调整了。

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.

正如我已经提到的那样,sub可以很好地使用相干选择以及多个选定的行,但是当涉及多个列时会失败。

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

正如人们所料,我希望.csv文件(或相应的.txt文件)看起来像这样:多列需要输出

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.

如何在最后一个案例中实现所需的行为?有人会如此善良地将链接包含在图像中吗?当然,如果认为合适的话。

1 个解决方案

#1

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

#1