Home > Software engineering >  VBA to extraxt text from string
VBA to extraxt text from string

Time:11-28

I have a dataset in excel which looks like this:

enter image description here

There can be more cells with data. I am trying to extract data from these big cells and paste values to more comprehensive table, which should look like this:

enter image description here

What would be the best way to proceed? I imagine process should look like this: Select range of filled cells, store row count as value Do a loop for that many rows as value Store whole cell value as string Find "Btc = *" and store it as btc value. Paste that value into prefered table Find "Qua= *" and store it as qua value. Paste that value into prefered table ..etc Clean up cells in new table using Replace

I am stuck on extracting part of text to value. What function can I use to assign that "Btc = *" to variable? Like operator gets be a whole string, but I only need parts of it Or maybe you have ideas on how to do this task easier?

CodePudding user response:

Please, try the next code. It uses arrays and will be very fast (working mostly in memory). Please adapt your real sheet used as destination, where the processed result to be dropped (shDest). Now, the code returns in the next sheet. If you want it as it is, please insert/have an empty sheet after the one to be processed:

Sub extractValTranspose()
  Dim sh As Worksheet, shDest As Worksheet, lastR As Long, arr, arrFin
  Dim i As Long, k As Long, j As Long
  
  Set sh = ActiveSheet 'use here the sheet to be processed
  Set shDest = sh.Next 'use here the sheet where you want the processed result to be dropped
  
  lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row 'last row in A:A
  arr = sh.Range("A2:A" & lastR).Value2               'place the range in an array for faster iteration/procesing
  ReDim arrFin(1 To UBound(arr) / 10   1, 1 To 10)    'redim the final array (to keep the processed data)
  
  'extract headers array:
  For i = 1 To 10
    arrFin(1, i) = Split(Replace(arr(i, 1), " ", ""), "=")(0) 'place the header on the first array row
    arrFin(2, i) = Split(Replace(arr(i, 1), " ", ""), "=")(1) 'place the data on the second row
  Next i
  
  k = 3: j = 1 'initialize variables keeping the (next) row and columns
  'place the rest of rows data:
  For i = 11 To UBound(arr)
    arrFin(k, j) = Split(Replace(arr(i, 1), " ", ""), "=")(1): j = j   1
    If j = 11 Then k = k   1: j = 1 'reinitialize the variable for each 10 rows
  Next
  
  'drop the array content, at once and do a little formatting:
  With shDest.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
    .Value2 = arrFin
    .EntireColumn.AutoFit
    .Borders.Color = vbBlack
    .BorderAround 1, xlMedium
    With .Rows(1)
        .Font.Bold = True
        .BorderAround 1, xlMedium
        .HorizontalAlignment = xlCenter
     End With
  End With
  
  MsgBox "Ready..."
  shDest.Activate
End Sub

CodePudding user response:

Transform Data With Split

Sub TransformData()

    ' Define constants.

    Const SRC_NAME As String = "Sheet1"
    Const SRC_COLUMN As Long = 1
    Const SRC_ROW_DELIMITER As String = vbLf ' vbCrLf?
    Const SRC_COL_DELIMITER As String = "="
    Const DST_NAME As String = "Sheet2"
    Const DST_FIRST_COLUMN As Long = 2
    Const OVERWRITE_MODE As Boolean = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the source data to an array, the source array ('sData').
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    
    Dim sData() As Variant, srCount As Long
    
    With sws.UsedRange
        srCount = .Rows.Count - 1
        If srCount = 0 Then
            MsgBox "No data in the source worksheet.", vbExclamation
            Exit Sub
        End If
        With .Columns(SRC_COLUMN).Resize(srCount).Offset(1) ' source data range
            If srCount = 1 Then
                ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
            Else
                sData = .Value
            End If
        End With
    End With
    
    ' Write the destination header data to an array ('hData') and reference
    ' the first destination row range ('dfrrg').
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    Dim dfrrg As Range, hData() As Variant, dcCount As Long, dc As Long
    
    With dws.UsedRange
        Dim dcOffset As Long: dcOffset = DST_FIRST_COLUMN - 1
        dcCount = .Columns.Count - dcOffset
        With .Columns(1).Resize(, dcCount).Offset(, dcOffset) ' header range
            If OVERWRITE_MODE Then
                Set dfrrg = .Rows(1).Offset(1)
            Else
                Set dfrrg = .Rows(1).Offset(.Rows.Count)
            End If
            hData = .Value
        End With
    End With
    
    ' Write the destination header data to a dictionary.
    
    Dim hDict As Object: Set hDict = CreateObject("Scripting.Dictionary")
    hDict.Comparemode = vbTextCompare
    
    For dc = 1 To dcCount: hDict(hData(1, dc)) = dc: Next dc
    
    If hDict.Count < dcCount Then
        MsgBox "No duplicates are allowed in the destination header row.", _
            vbExclamation
        Exit Sub
    End If
    
    Erase hData
    
    ' Define the destination array ('dData').
    ' Note that fewer rows are possible if blank or missing source values.
    
    Dim dData() As Variant: ReDim dData(1 To srCount, 1 To dcCount)
    
    ' Using the dictionary, write the matching values from the source array
    ' to the destination array.
    
    Dim sr As Long, sc As Long, sPos As Long, dr As Long, vLen As Long
    Dim sArr() As String, sString As String, sTitle As String, sValue As String
    Dim InNextRow As Boolean
    
    For sr = 1 To srCount
        sArr = Split(CStr(sData(sr, 1)), SRC_ROW_DELIMITER)
        For sc = 0 To UBound(sArr)
            sString = CStr(sArr(sc))
            sPos = InStr(sString, SRC_COL_DELIMITER)
            If sPos > 1 Then ' column delimiter it not the first character
                sTitle = Left(sString, sPos - 1)
                If hDict.Exists(sTitle) Then ' title found in the dictionary
                    vLen = Len(sString) - sPos
                    If vLen > 0 Then ' has a value
                        sValue = Right(sString, vLen)
                        If Not InNextRow Then dr = dr   1: InNextRow = True
                        dData(dr, hDict(sTitle)) = sValue
                    End If
                End If
            End If
        Next sc
        If InNextRow Then InNextRow = False
    Next sr
    
    If dr = 0 Then
        MsgBox "No values found in the source worksheet.", vbExclamation
        Exit Sub
    End If
    
    Erase sData
    
    ' Write the values from the destination array to the destination range.
    
    dfrrg.Resize(dr).Value = dData ' 'dr', not 'srCount'
    If OVERWRITE_MODE Then ' clear below
        dfrrg.Resize(dws.Rows.Count - dfrrg.Row - dr   1).Offset(dr).Clear
    End If
    
    ' Inform.
    
    MsgBox "Data transformed.", vbInformation

End Sub
  • Related