Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

[DocAElstein]

Macro for last post

Option Explicit
Sub StartOffvbadumbarse()
Rem 1 Worksheets info
Dim WsIn As Worksheet, WsOut As Worksheet
 Set WsIn = ThisWorkbook.Worksheets.Item(1): Set WsOut = ThisWorkbook.Worksheets.Item(2)
Dim arrIn() As Variant: Let arrIn() = WsIn.Range("B1:F5").Value2
Rem 2
'2b
Dim Clm As Long
    For Clm = 1 To 5 Step 1
        If arrIn(1, Clm) = "" Then
        ' Nothing to do for no header
        Else
        Dim Itms As String: Let Itms = arrIn(1, Clm)
        Dim RwDta As Long
            For RwDta = 2 To 5 Step 1
            Dim strFndWd As String
                If arrIn(RwDta, Clm) = "" Then
                ' no data
                Else
                    If InStr(1, arrIn(RwDta, Clm), "|", vbBinaryCompare) > 0 Then ' we must have two or more datas seperatied by a  |
                    Dim CelDts As Long
                        For CelDts = 0 To UBound(Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare))
                         Let strFndWd = strFndWd & Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare)(CelDts) & vbCr & vbLf
                        Next CelDts
                    Else ' case single data
                     Let strFndWd = strFndWd & arrIn(RwDta, Clm) & vbCr & vbLf  ' effectively a single row is added for this data
                    End If
                End If
            Next RwDta
        '2e we have been through the data, so time to see what we got and fill our two strings appropriately
        Dim strOutA As String, strOutB As String
            If strFndWd = "" Then ' case we had no data
             Let strFndWd = strFndWd & vbCr & vbLf ' effectively adds an empty row
             Let strOutA = strOutA & Itms & vbCr & vbLf ' a single row with header
            Else ' we have data, so need do add some rows to strOutA ( strOutB effecively has all the rows determined by the number of  vbCr & vbLf   added
            Dim RwCnt As Long: Let RwCnt = UBound(Split(strFndWd, vbCr & vbLf, -1, vbBinaryCompare)) + 1 - 1 ' The number of  vbCr & vbLf  gives us the number rows
                For CelDts = 1 To RwCnt
                 Let strOutA = strOutA & Itms & vbCr & vbLf
                Next CelDts
            End If
        End If
     Let strOutB = strOutB & strFndWd
     Let strFndWd = ""
    Next Clm
' I can view my data in a message box or in the immediate window
 MsgBox Prompt:=strOutA: Debug.Print strOutA
 MsgBox Prompt:=strOutB: Debug.Print strOutB

Rem 3 outout
Dim arrOutA() As String: Let arrOutA() = Split(strOutA, vbCr & vbLf, -1, vbBinaryCompare) '  Excel has the convention of taking a  1D  array as being "horizontal" for spreadsheet purposes, so will consider it as a row of data values if applied to a worksheet range
Dim arrOutB() As String: Let arrOutB() = Split(strOutB, vbCr & vbLf, -1, vbBinaryCompare)
' Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Transpose(arrOutA())
 Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Index(arrOutA(), Evaluate("=row(1:" & UBound(arrOutA()) & ")/row(1:" & UBound(arrOutA()) & ")"), Evaluate("=row(1:" & UBound(arrOutA()) & ")"))
' Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Transpose(arrOutB())
 Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Index(arrOutB(), Evaluate("=row(1:" & UBound(arrOutB()) & ")/row(1:" & UBound(arrOutB()) & ")"), Evaluate("=row(1:" & UBound(arrOutB()) & ")"))
End Sub