-
1 Attachment(s)
VBA Macro which creates new lines by codes
Hi, everyone!
I've got a task to bring an excel document to its normal appearance. The "Old" sheet has some codes separated by semicolons and dashes in column B. I need to have only 1 code in each line (as in the "New" sheet). That is, it is necessary that Excel automatically creates new lines with only one code, with just duplicating data from the other columns. Also, if a code is, for example, "101-104" in a cell, Excel is to create 4 lines with codes 101, 102, 103, 104 separately.
You can already see the green cells as an example.
The task is to provide a VBA macro, not just create a new sheet manually.
I really ask for your help!
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg. 9irLgSdeU3r9itU7zdnWHw
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htJ6TpIOXR
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htOKs4jh3M
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
-
1 Attachment(s)
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
Code:
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
-
1 Attachment(s)
In the attached, update the table on the Old sheet, then on the New sheet, right-click on the table at cell J1 and choose Refresh…
Constraints: No negative numbers in the Code column, all codes should look like numbers, hyphenated code number pairs should start with the lesser value.
If you have hyphenated number-pairs that overlap (2-6;4;8;1-10) you will get duplicate rows but these can be eliminated if you want.
-
1 Attachment(s)
Alan,
This is just amazing! The macro works almost perfectly. I appreciate your help!
However, I've faced a problem: in my original list there are some codes that start with 0, for example, '060-062'. I decided to use if-clause and apparently it works, but the current problem lies in 2c part, in particular, in arrOutTempCT() that ignores nulls at the beginning of a code since it is variant and makes them just '60; 61; 62'. I've got no idea how to make it put codes without eradicating 0. I tried to change arrOutTempCT() from variant to string, but certainly it didn't work.
-
Quote:
Originally Posted by
Alex Salt
.... I decided to use if-clause and apparently it works, ......
..? ...Can you elaborate on what you mean by that, please
( Do you have any feedback for P45cal on his attempt for you )
-
1 Attachment(s)
I mean 'If...Then...Else Statement' so that the macro would add '0' at the beginning of some codes if there was one initially (otherwise it erases '0'), you can see it in the attachment. Anyways, the problem is that the macro ignores '0' at the beginning of some codes (even if I add '0' in if-statement). I wonder if there is any solution, and i think there can be something done with arrOutTempCT().
-
1 Attachment(s)
Quote:
Originally Posted by
DocAElstein
( Do you have any feedback for p45cal on his attempt for you )
We're getting .xls files but his profile shows Office 2016+ so the Power Queries should work.
In general, if someone I've tried to help completely ignores that help, I return the compliment when they later want further help.
That said, the attached includes a tweak to the query which tries to maintain the formatting.
-
1 Attachment(s)
@ P45cal
Hello Pascal
I agree with you on that. I think its inevitably going to get worse, because forums are increasingly just seen as an alternative to a Google search and/ or an answer and question section working on Artificial Intellisense. The idea of Human things like politeness and feedback is going out of fashion.
I think the forum is for extending the knowledge and encouraging discussions in Excel stuff. So regardless of OP reaction, adding extra alternative solutions like you did is always worthwhile for the greater long term good. ( In 10 years, when I finally figure out what Power Query is about , Lol, then it will be interesting to come back and see how you did here something in Power Query compared to like I did it here with VBA. )
When I finally take over this place, my first priority will be to trim out the crap and, very importantly, my main priority will be to keep the place here as long as possible. So feel free to keep adding replies. They won’t be lost!
( Just a couple of very minor points in this case though:
_ I might be responsible for the .xls files. He started with .xlsx, but I like to do everything in .xls first, so I probably first introduced using .xls and so I am responsible for any confusion on that one..
_ I think Email notifications of replies in Threads you are subscribed to may be broken at excelfox just now, so OPs might miss replies. I don’t know if it’s a temporary glitch or may need some work to fix. ( Let me know please if Email notifications are working for you, assuming you have your settings to get them.) All my setting are to get all Email notifications. But since a month they have stopped working for me.
( Because excelfox has such little traffic, my temporary solution currently is to send an extra Email to OPs to tell them about any reply, as I did for the OP in this Thread… - I have access to OPs personal EMail and I abuse that privilege at will :)
Later I intend giving that sort of "power" to all helpers , such as yourself. Those that help should have all the tools available, IMO )… )
@ Alex
Hi Alex,
Quote:
Originally Posted by
Alex Salt
...I've faced a problem: in my original list there are some codes that start with 0, for example, '060-062'. I decided to use if-clause and apparently it works, but the current problem lies in 2c part, in particular, in arrOutTempCT() that ignores nulls at the beginning of a code since it is variant and makes them just '60; 61; 62'. I've got no idea how to make it put codes without eradicating 0. I tried to change arrOutTempCT() from variant to string, but certainly it didn't work
...... i think there can be something done with arrOutTempCT()
It did sound reasonable to me initially that the transposing ( that is what arrOutTempCT() is all about ) might be the problem.
However I took a quick look here: , https://excelfox.com/forum/showthrea...ll=1#post15541 , and that transposing does not seem to be the problem. If you look at the Watch Window results, you can see we maintain our string in the array arrOutTempCT()
My guess at this stage is that we have two issues :
_(i) Code section ' 2b is using maths to modify something like 3-5 type data into 3 4 5. So this is likely always to convert 03-05 into 3 4 5
You appear to have had some success in curing that with this bit.
Code:
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
Next Cnt
If you then look once again at your array contents, then you still have what you want : For example in your test data for row with 18; 061-069, this here: https://excelfox.com/forum/showthrea...ll=1#post15542 , is what you see.
Once again, the transpose is not the problem
It looks initially as if you have already cured the main problem yourself
_(ii) The remaining issue I think is the whole “can of worms” area of Excel deciding it knows better than you what you should see.
What Excel is doing is deciding that you are pasting in a number when you paste in like 061. It decides that the number is 61
There are a lot of different ways to overcome such problems.
The simplest way is to manually change the format of column C in the New worksheet to text, as I have done in the uploaded returned file. Basically, as I understand it, using text format short circuits Excel trying to modify anything – basically with text format you get what you give.
If you want a different solution, then we can think again later…
In short, your modified macro is giving what you want. But Excel is changing the format you give it. The simple cure I have done is manual. We can come up with various ways to overcome the problem in the coding, should you prefer to start with a virgin New worksheet with all default formats.
Alan
-
p45cal,
I'm sorry for ignoring, I completely forgot to answer you.
My point is that I need a VBA code (macro) that I could use for other worksheets. I see no macro in your solution. You solved the problem by using table-tools, which is not the thing I need.
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
-
It's my first time using forums so, please, don't be so judging, it's quite a new environment for me.
DocAElstein,
Now everything works perfectly, and you cannot imagine how I appreciate your effort and help! I wish I could pay you back equally.
