VBA Macro which create new lines by codes

[DocAElstein]

Hello Alex,
Welcome to ExcelFox

I think something like this could be solved in VBA in many different ways. So many that it would probably take me personally a very long time to go through them all and decide which is the best. - I don’t have the time for all that, so I will do the first solution that comes into my head to get you started.
It’s unlikely that it would be the best or most efficient solution.

Here a quick summary of my thinking, and the solution which I am making up as I go along and writing the solution
I took a quick look here: https://excelfox.com/forum/showthrea...5531#post15531 , at some of your data in column C. It doesn’t look as though there are any unusual or “hidden” characters in it
"655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"
In simple terms : It looks as though what you see is what you have.

I personally would usually use VBA array techniques whereby I capture all data into an internal array in memory that I cannot see, and access that with VBA coding , get all my results, then paste them out to the new worksheet in one go.
The main reason for that is that interacting with many cells in a worksheet can be very inefficient.
But in this case a lot of information is in a single cell in column C, and I also notice that we finally want in some columns the same value pasted out into many cells. So in your particular case, our interaction with the worksheet is minimised – I can sometimes take a lot of information in , in one go , and can sometimes paste out a lot of information in one go

General macro coding explanation
Rem 2
I have a main loop going down all your name cells =====
' 2b This deals with converting any numbers ranges written like 101-104
' 2c The modified data in simple number form for the column C list is produced in a 1 D array, arrOutTempC(). Excel recognises such an array as pseudo horizontal like in a row, so we transpose that to produce a pseudo like single column array, arrOutTempCT()
' 2d All the column data for a particular name is pasted out

I have not tested thoroughly, and there are likely other tweaks necessary to get finally exactly what you want, but it should get you started. At first glance it seems to do what you want - See here https://excelfox.com/forum/showthrea...ll=1#post15533

Alan

---

Option Explicit
Sub Alex1() '  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 into  like  3; 4; 5
    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 Long, StpN As Long '  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
            For Cnt = StrtN To StpN Step 1
            Dim NRngMod As String
             Let NRngMod = NRngMod & Cnt & "; "
            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