Question

我想将给定范围内的值转换为VBA字符串，其中原始单元格值由任何选定的列分隔符和行分隔符分隔。分隔符可以是一个字符或更长的字符串。行分隔符是该行末尾的字符串。字符串应该在我们从左上角，从左到右，到右下角读取文本时完成。

以下是A1范围内的VALUES示例：C5：

+----+----+----+
| A1 | B1 | C1 |
+----+----+----+
| A2 | B2 | C2 |
+----+----+----+
| A3 | B3 | C3 |
+----+----+----+
| A4 | B4 | C4 |
+----+----+----+
| A5 | B5 | C5 |
+----+----+----+

所需结果是VBA字符串：

A1,B1,C1@$A$2,$B$2,$C$2@A3,B3,C3@A4,B4,C4@A5,B5,C5@

为了便于阅读，我将这样展示：

A1,B1,C1@
A2,B2,C2@
A3,B3,C3@
A4,B4,C4@
A5,B5,C5@

作为列分隔符，我选择了,（逗号），并选择了行分隔符@。当然，这些可能是\r\n等任何字符。

我想要从范围快速烹饪字符串的原因是因为我想通过ADO连接将其发送到SQL Server。正如我到目前为止测试的那样，它是即时传输大量数据的最快方法。如何在SQL Server上拆分此字符串的双重问题是：Split string into table given row delimiter and column delimiter in SQL server

解决方案1。遍历所有行和列。问题是，如果有更优雅的方式，然后循环所有行和列？我更喜欢VBA解决方案，而不是公式一。

解决方案2。 Mat的评论中提出了建议。 CSV文件是理想的结果。我想在不保存的情况下即时完成。但好点 - 模仿CSV是我想要的，但我想要它而不保存。

赏金后编辑

Thomas Inzina的答案疯狂快速，他的解决方案是便携式的。普通的VBA循环比大型数据集上的JOIN等工作表函数更快。我不建议在VBA中使用工作表函数来实现此目的。我已经投票给所有人。谢谢大家。

Answer 1

为了优化性能，我的函数模拟了一个String Builder。

变量

文本：用于保存数据的非常大的字符串
CELLLENGTH：决定BufferSize
BufferSize：文本字符串的初始大小
Data（）：从源范围派生的数组

当Data（）数组的行和列在当前元素（Data(x, y)）上迭代时，值将替换Text字符串的一部分。根据需要调整文本字符串的大小。这极大地减少了连接的数量。最初的BufferSize设置得相当高。我得到了最好的结果，0.8632813秒，将CELLLENGTH降低到25。

Download Sample Data from Sample-Videos.com

结果

代码

Function getRangeText(Source As Range, Optional rowDelimiter As String = "@", Optional ColumnDelimiter As String = ",")
    Const CELLLENGTH = 255
    Dim Data()
    Dim text As String
    Dim BufferSize As Double, length As Double, x As Long, y As Long
    BufferSize = CELLLENGTH * Source.Cells.Count
    text = Space(BufferSize)

    Data = Source.Value

    For x = 1 To UBound(Data, 1)
        If x > 1 Then
            Mid(text, length + 1, Len(rowDelimiter)) = rowDelimiter
            length = length + Len(rowDelimiter)
        End If

        For y = 1 To UBound(Data, 2)
            If length + Len(Data(x, y)) + 2 > Len(text) Then text = text & Space(CDbl(BufferSize / 4))
            If y > 1 Then
                Mid(text, length + 1, Len(ColumnDelimiter)) = ColumnDelimiter
                length = length + Len(ColumnDelimiter))
            End If

            Mid(text, length + 1, Len(Data(x, y))) = Data(x, y)
            length = length + Len(Data(x, y))
        Next
    Next

    getRangeText = Left(text, length) & rowDelimiter
End Function

测试

Sub TestGetRangeText()
    Dim s As String
    Dim Start: Start = Timer

    s = getRangeText(ActiveSheet.UsedRange)

    Debug.Print "Execution Time: "; Timer - Start; "Second(s)"
    Debug.Print "Rows: "; ActiveSheet.UsedRange.Rows.Count; "Columns: "; ActiveSheet.UsedRange.Columns.Count
    Debug.Print "Result Length: "; Format(Len(s), "#,###")
End Sub

Answer 2

这是一种快速测试方法（注意：这只适用于Excel 2016（或者如果你有TextJoin()功能）。

首先，在空列D中，执行=C1&"@"，这样您的最后一列就会填充单元格+ @

然后，在单元格E1中说=TEXTJOIN(",",TRUE,A1:C5) （注意：TRUE表示跳过空白。如果您有空白，并希望保留空白，请将其更改为FALSE。

然后，在那个单元格上，运行

=Substitute(E1,"@,","@")

或将公式合并为一个：=SUBSTITUTE(TEXTJOIN(",",TRUE,A1:C4),"@,","@")。

如果需要 vba，只需将公式放入VBA宏并按此运行。

Answer 3

这是一个返回所需输出的UDF：

编辑更改为最后添加EOL。

Option Explicit
Function MultiJoin(Rng As Range, Delimiter As String, EOL As String) As String
    Dim V As Variant, W As Variant
    Dim COL As Collection
    Dim I As Long, J As Long

V = Rng
Set COL = New Collection
ReDim W(1 To UBound(V, 2))
For I = 1 To UBound(V, 1)
    For J = 1 To UBound(V, 2)
        W(J) = V(I, J)
    Next J
    COL.Add W
Next I

ReDim V(1 To COL.Count)
For I = 1 To COL.Count
    V(I) = Join(COL(I), Delimiter)
Next I

W = Join(V, EOL)
MultiJoin = W & EOL

End Function

可以使用WorksheetFunction来缩短代码，但我猜测执行时间会更慢。

缩短代码

Option Explicit
Function MultiJoin(Rng As Range, Delimiter As String, EOL As String) As String
    Dim V As Variant, W As Variant
    Dim I As Long, J As Long

V = Rng
With WorksheetFunction

For I = 1 To UBound(V, 1)
    V(I, 1) = Join(.Index(V, I, 0), Delimiter)
Next I
MultiJoin = Join(.Transpose(.Index(V, 0, 1)), EOL) & EOL

End With

End Function

Answer 4

此解决方案将需要在项目中引用Microsoft Forms 2.0对象库或以其他方式获取剪贴板的内容（例如通过API调用）。

Function TurnExcelRangeIntoVBAString(Optional cellDelimiter As String = ",", _
                                     Optional rowDelimiter As String = "@") _
         As String

    Dim rng As Range
    Set rng = ActiveSheet.UsedRange
    rng.Copy

    Dim clip As New MSForms.DataObject
    Dim txt As String
    clip.GetFromClipboard
    txt = clip.GetText()
    txt = Replace(Replace(txt, vbTab, cellDelimiter), vbCrLf, rowDelimiter)

    TurnExcelRangeIntoVBAString = txt
End Function

Answer 5

你可以试试这个

Option Explicit

Sub main()
    Dim strng As String
    Dim cell As Range

    With Worksheets("TurnRangeIntoString") '<--| change "TurnRangeIntoString" to your actual worksheet name
        For Each cell In Intersect(.UsedRange, .Columns(1)) '<--| loop through its column 1 cells
            strng = strng & Join(Application.Transpose(Application.Transpose(.Range(cell, cell.End(xlToRight)).value)), ",") & "@" '<--| build string
        Next cell
    End With
    MsgBox strng
End Sub

Answer 6

Sub aquatique()
dim a(),s$,i&,j&:a=selection.value
for i=1 to ubound(a)
for j=1 to ubound(a,2)
    if j=1 then
        if i=1 then
            s=  a(i,j)
        else
            s=s &"@" & vbnewline & a(i,j)
        end if
    else
        s=s &";" & a(i,j)
    end if
next
next
end sub

简单但完成工作。在大范围内减速，你需要使用“加入”

Answer 7

这个怎么样？：

Sub Concatenate()
Dim Cel As Range, Rng As Range
Dim sString As String, r As Long, c As Long, r2 As Long

Set Rng = Selection
r = Selection.Row
c = Selection.Column
r2 = Selection.Row
For Each Cel In Rng
    r = Cel.Row
    If sString = "" Then
        sString = Cel.Value
        Else
            If r <> r2 Then sString = sString & "@" & Cel.Value
            If r = r2 Then sString = sString & "," & Cel.Value
    End If
    r2 = Cel.Row
Next

sString = sString & "@"
Debug.Print sString

End Sub

将Excel范围转换为VBA字符串

7 个答案:

结果

代码

测试