I would like to turn values in given range into VBA string where original cell values are separated by any chosen column delimiter and row delimiter. Delimiters could be one
This solution will require either a reference to the Microsoft Forms 2.0 Object Library in your project or some other way of fetching the contents of the clipboard (like through an API call).
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
To optimize performance my function emulates a String Builder.
Variables
As the rows and columns of the Data() array are iterated over the current element (Data(x, y)
) value replaces a portion of the Text string. The text string is resized as needed. This reduces the number of concatenations immensely. The initial BufferSize is set pretty high. I got my best results, 0.8632813 Second(s), by reducing CELLLENGTH to 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
Here's a quick way to test (Note: this will only work with Excel 2016 (or if you have the TextJoin()
function).
First, in the empty column D, do =C1&"@"
, so you get your last column filled with the cell+@
Then, say in cell E1, =TEXTJOIN(",",TRUE,A1:C5)
(Note: TRUE
there means to skip blanks. If you have blanks, and want to keep them, change that to FALSE
).
THen, on that cell, run
=Substitute(E1,"@,","@")
Or combine the formulas into one: =SUBSTITUTE(TEXTJOIN(",",TRUE,A1:C4),"@,","@")
.
If you need vba, just throw the formula into a VBA macro and run like that.
you could try this
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
How about this?:
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
Here is a UDF that returns the desired output:
EDIT Changed to add EOL at the end.
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
One could shorten the code by using WorksheetFunction
s, but I would guess execution time would be slower.
Shortened Code
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