3

VBA を使用して、選択した範囲のセルを .csv ファイルにエクスポートできるようにしたいと考えています。私がこれまでに思いついたことは、選択のまとまりには優れていますが、複数の列が選択されていると悲惨なことに失敗します。

インターネットで見つけたスニペットからなんとかまとめたコードを次に示します。これは、いくつかの UI をいじることもできます。私の 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

すでに述べたように、サブは一貫した選択と複数の選択された行でうまく機能しますが、複数の列になると失敗します。

サブの現在の出力は、この画像で確認できます: 複数の列が失敗しました

予想通り、.csv ファイル (またはそれぞれの .txt ファイル) を次のようにしたいと考えています 。

最後のケースで望ましい動作を実現するにはどうすればよいですか? そして、誰かがリンクを画像として含めてくれませんか? もちろん、適切と思われる場合。

4

1 に答える 1

2

これは少し複雑に思えるかもしれませんが、ユースケースはそれほど単純ではありません...

選択した各領域が同じサイズであり、すべてが (行または列として) 並んでいると想定しています。

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
于 2013-02-20T01:21:58.283 に答える