Turn Excel range into VBA string

前端 未结 7 1728
野性不改
野性不改 2020-11-30 11:51

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

相关标签:
7条回答
  • 2020-11-30 12:14

    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
    
    0 讨论(0)
  • 2020-11-30 12:19

    To optimize performance my function emulates a String Builder.

    Variables

    • Text: A very large string to hold the data
    • CELLLENGTH: A contant that determines the size of the BufferSize
    • BufferSize: The initial size of Text string
    • Data(): An Array derived from the source range

    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

    Results

    Code

    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
    

    Test

    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
    
    0 讨论(0)
  • 2020-11-30 12:22

    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.

    0 讨论(0)
  • 2020-11-30 12:23

    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
    
    0 讨论(0)
  • 2020-11-30 12:25

    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
    
    0 讨论(0)
  • 2020-11-30 12:26

    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 WorksheetFunctions, 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
    
    0 讨论(0)
提交回复
热议问题