VBA to extraxt text from string - excel

Question

I have a dataset in excel which looks like this:
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:
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?

Answer 1

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
Edited:
Nothing from your question made me understand that all groups of 10 strings to be processed are in the same cell...
Please, test the next piece of code able to process the above mentioned range type:
Sub extractValSameCellTranspose()
Dim sh As Worksheet, shDest As Worksheet, lastR As Long
Dim arr, arrCell, arrFin, 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), 1 To 10) 'redim the final array (to keep the processed data)
'extract headers and first row of data:
arrCell = Split(arr(1, 1), vbLf) 'split the cell content on vbLf (end of line)
For i = 0 To UBound(arrCell) 'iterate between the above array elements
arrFin(1, i + 1) = Split(VBA.replace(arrCell(i), " ", ""), "=")(0) 'place the header on the first array row
arrFin(2, i + 1) = Split(VBA.replace(arrCell(i), " ", ""), "=")(1) 'place the data on the second row
Next i
k = 3 'initialize variable keeping the array rows
'place the rest of rows data:
For i = 3 To UBound(arr)
arrCell = Split(arr(i, 1), vbLf)
For j = 0 To UBound(arrCell)
arrFin(k, j + 1) = Split(VBA.replace(arrCell(j), " ", ""), "=")(1)
Next j
k = k + 1
Next
'drop the array content, at once and do a little formatting:
With shDest.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.Value2 = arrFin 'drop the array content
.EntireColumn.AutoFit 'autofit all columns
.Borders.Color = vbBlack 'place some thin borders on each cell
.BorderAround 1, xlMedium 'place a thicker border arround the whole range
With .rows(1) 'format the first (headers) row:
.Font.Bold = True 'make the font bold
.BorderAround 1, xlMedium 'place a thicker border arround
.HorizontalAlignment = xlCenter 'center the string horizontaly
End With
End With
MsgBox "Ready..."
shDest.Activate 'activate the sheet where the processed result has been dropped
End Sub
Please, send some feedback after testing it.

Answer 2

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