将Excel范围转换为VBAstring

我想将给定范围内的值转换成VBAstring，其中原始单元格值由任何选定的列分隔符和行分隔符分隔。 分隔符可以是一个字符或更长的string。 行分隔符是行尾的string。 string应该像我们从左上angular，从左到右，到右下angular读文本一样。

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

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

期望的结果是一个VBAstring：

 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@ 

作为列分隔符，我select了（逗号）和行分隔符@符号。 当然这些可以是\r\n类的任何字符。

我想从范围快速烹饪string的原因是因为我想通过ADO连接发送到SQL Server。 正如我迄今为止testing过的那样，这是最快速地传输大量数据的方法。 如何在SQL Server上拆分这个string的双胞胎问题在这里：将string拆分成SQL服务器中给定的行分隔符和列分隔符

解决scheme1.遍历所有行和列。 问题是如果有更优雅的方式，然后循环遍历所有的行和列？ 我宁愿VBA解决scheme，而不是公式之一。

解决scheme2.由Mat's Mugbuild议评论。 CSV文件是理想的结果。 我想在没有保存的情况下在飞行中执行此操作。 但好点 – 模仿CSV是我想要的，但我希望它没有保存。

赏金后编辑

Thomas Inzina的答案疯狂的工作，他的解决scheme是便携式的。 普通的VBA循环结果是比大型数据集上的JOIN更快的工作表函数。 我不build议在VBA中使用工作表函数。 我已经把每个人都投了票。 谢谢你们。

Answer 1

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

variables

• 文本：一个非常大的string来保存数据
• CELLLENGTH：一个确定BufferSize大小的容器
• BufferSize：文本string的初始大小
• Data（）：从源范围派生的数组

由于Data（）数组的行和列在当前元素（ Data(x, y) ）上迭代，所以将replaceTextstring的一部分。 文本string根据需要resize。 这极大地减less了连接的数量。 初始BufferSize设置得相当高。 我得到了我最好的结果，0.8632813秒，通过减lessCELLLENGTH为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 

testing

 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

这里有一个快速的testing方法（注意：这只适用于Excel 2016（或者如果你有TextJoin()函数）。

首先，在空的D列中，do =C1&"@" ，所以你得到最后一列填充单元格+ @

然后，在单元格E1中， =TEXTJOIN(",",TRUE,A1:C5) （注意： TRUE意思是跳过空格，如果有空格，并且想保留它们，则改为FALSE ）。

在那个单元格上运行

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

或者将这些公式组合成一个： =SUBSTITUTE(TEXTJOIN(",",TRUE,A1:C4),"@,","@") 。

如果您需要 vba，只需将公式引入VBAmacros，然后像这样运行。

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

此解决scheme将需要对项目中的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 

简单但是做的工作。 在大范围内缓慢，你需要使用“join”

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