Code:
Sub AlexAlanPascal() ' https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15549#post15549 https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539 https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
Rem 1 Worksheets info
Dim WsOld As Worksheet, WsNew As Worksheet
Set WsOld = ThisWorkbook.Worksheets("Old"): Set WsNew = ThisWorkbook.Worksheets("New")
Dim Lr As Long: Let Lr = WsOld.Range("A" & WsOld.Rows.Count & "").End(xlUp).Row ' https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files-or-single-Excel-File?p=11467&viewfull=1#post11467
Rem 2
Dim ACel As Range, TLeft As Long: Let TLeft = 2 ' This variable holds the position of the next section in the New worksheet
For Each ACel In WsOld.Range("A2:A" & Lr & "") ' main loop going down all name cells ======
Dim AName As String: Let AName = ACel.Value2
Dim CVal As String: Let CVal = ACel.Offset(0, 2).Value2 & ";" ' I need the extra ; or otherwise I might miss the last number range ( number range is something like 45-48 ) if there is one, because I look for the ; in order to determine where that number rang ends
' 2b modifying any 3-5 type data
Dim PosDsh As Long: Let PosDsh = InStr(1, CVal, "-", vbBinaryCompare)
Do While PosDsh > 0 ' Position of the dash will be returned as 0 by the Instr function if the Instr function cannot find a next dash. Also my coding below might retun me -1 at this line ---###
Dim StrtN As String, StpN As String ' I use these variables initially for the position of the number and then the actual number
Let StrtN = InStrRev(Left(CVal, PosDsh), " ", -1, vbBinaryCompare) + 1
Let StrtN = Mid(CVal, StrtN, PosDsh - StrtN)
Let StpN = InStr(PosDsh, CVal, ";", vbBinaryCompare)
Let StpN = Mid(CVal, PosDsh + 1, (StpN - 1) - PosDsh)
Dim NRng As String
Let NRng = StrtN & "-" & StpN
Dim Cnt As Long, Padding As Long
Let Padding = Len(StrtN)
For Cnt = StrtN To StpN Step 1
Dim NRngMod As String
' Dim FrstSym As String
' Let FrstSym = Left(NRng, 1)
' If FrstSym = 0 Then
' Let NRngMod = NRngMod & "0" & Cnt & "; "
' Else
' Let NRngMod = NRngMod & Cnt & "; "
' End If
Let NRngMod = NRngMod & Format(Cnt, Application.Rept(0, Padding)) & "; "
Next Cnt
Let NRngMod = Left(NRngMod, Len(NRngMod) - 2) ' I don't need the last 2 characters of "; "
Let CVal = Replace(CVal, NRng, NRngMod & "|", 1, 1, vbBinaryCompare) ' I haver a temporary "|" to indicate the end of the last modified bit
Let PosDsh = InStr((InStr(1, CVal, "|", vbBinaryCompare)), CVal, "-", vbBinaryCompare) - 1 ' because I start looking at just after the last modified part, this will return me the position of the next one, ( or 0 if none is found ) -1 is because I am reducing the length by 1 in the next code line ---###
Let CVal = Replace(CVal, "|", "", 1, 1, vbBinaryCompare)
Let NRngMod = "" ' rest this variable for next use '
Loop
' 2c Modified column C output
Let CVal = Replace(CVal, ";", "", 1, -1, vbBinaryCompare) ' I don't want any ; in the modified list
Dim arrOutTempC() As String '
Let arrOutTempC() = Split(CVal, " ", -1, vbBinaryCompare)
Dim arrOutTempCT() As Variant
Let arrOutTempCT() = Application.Index(arrOutTempC(), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")/row(1:" & UBound(arrOutTempC()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")"))
' 2d All New column output
Let WsNew.Range("C" & TLeft & ":C" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = arrOutTempCT()
Let WsNew.Range("A" & TLeft & ":A" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Value2 ' Name
Let WsNew.Range("B" & TLeft & ":B" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 1).Value2 ' Number
Let WsNew.Range("E" & TLeft & ":E" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 4).Value2 ' Date
Let WsNew.Range("E" & TLeft & ":E" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").NumberFormat = "m/d/yyyy"
Let WsNew.Range("F" & TLeft & ":F" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 5).Value2 ' Currency
Let WsNew.Range("G" & TLeft & ":G" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 6).Value2 ' Min
Let WsNew.Range("H" & TLeft & ":H" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 7).Value2 ' Max
Let TLeft = TLeft + UBound(arrOutTempCT(), 1) ' this should adjust our top left cell for next range of new columns
Next ACel ' ' main loop going down all name cells =========
End Sub
Reply With Quote
Originally Posted by prkhan56
Bookmarks