Macro for last post
Code:
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
Reply With Quote
Bookmarks