将Excel范围转换为VBA字符串

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上拆分此字符串的孪生问题在于：在SQL Server 中给定行分隔符和列分隔符的情况下将字符串拆分为表

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

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

赏金后编辑

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

Answer 1

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

变量

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

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

从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中，do =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