vba 将选定的行和列导出到 CSV 文件
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/14970344/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Export selected rows and columns to CSV-file
提问by Huugo
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.
这是我从互联网上找到的片段中设法拼凑起来的代码：它还摆弄一些 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
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.
我怎样才能为最后一种情况实现所需的行为？有人会这么友好地将链接包含为图像吗？当然，如果认为合适的话。
采纳答案by Tim Williams
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
