Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Change multiple values in a cell, to multiple duplicate rows

Posted on 2011-03-08
10
Medium Priority
?
198 Views
Last Modified: 2012-05-11
Good Afternoon

I have previously asked the following question, and the code is the accepted answer. It works correctly but is there a faster away, or more efficent solution, either in code or tweaking my Excel settings. The code is running in Excel 2007.

The question:

I am looking to achive the following:

Within column W of a report, which is pull from a sharepoint site, it is possible to have mulitple entry's in the single cell, for example:

Apple;#1;#Orange;#2,#Nut;#14

What I would like is a piece of code which identifies the multiple entry, and creates a single row for each entry within the cell, so from the above example I would have three rows, with only one entry within the column W. The details held within the rest of the row apply to each entry, so a straight copy of the row would work.

The multiple entrys could be upto a maximum of 21 items.

Many thanks

The code:
Sub splitme()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ActiveSheet
Dim r As Range
Dim V As Variant
Dim a() As String
Dim i As Integer
Dim row As Long
Dim endRow As Long
Set r = Intersect(ws.UsedRange, ws.Range("W:W"))
row = r.row
endRow = r.row - 1 + r.Rows.Count
While row <= endRow
Set r = ws.Range("W" & row)
a = Split(r.Value, ";")
If UBound(a) > 2 Then
r.Value = a(0) & ";" & a(1)
For i = 2 To UBound(a) Step 2
V = r.EntireRow
r.EntireRow.Insert
r.EntireRow.Offset(-1) = V
'Set r = r.Offset(1)
If UBound(a) >= i + 1 Then
    r.Value = a(i) & ";" & a(i + 1)
Else
    r.Value = a(i)
End If
Next i
End If
row = r.row + 1
Wend
Application.ScreenUpdating = True
End Sub

Open in new window

0
Comment
Question by:Washcare
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 5
  • 4
10 Comments
 
LVL 6

Expert Comment

by:Eric Zwiekhorst
ID: 35069450
Dear Washcare,

Your code does excactly what you are demanding?
What seems to be the problem?

Kr

Eric
0
 
LVL 6

Expert Comment

by:Eric Zwiekhorst
ID: 35069501
Ah I see, you have a lot of data and it takes to long to run?

Well a way to speed up, and again it is limited by the amount of data you are having, is to handle everything in variables (Dataranges) and when everything is calculated just overwriting the entire sheet, that will be much faster then inserting rows..


Kind regards

Eric
0
 

Author Comment

by:Washcare
ID: 35069534
Eric

With 10705 rows of data, Excel is freezing, and when it does successfully complete its taking over 3hrs! I am asking if there is a more effective way of achieving my requirement?

Regards
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
LVL 6

Expert Comment

by:Eric Zwiekhorst
ID: 35069681
Well how many columns are you facing?
And after excel ahs finished how many rows do you have?

I need to now this to be able to see if you can do this with variable Arrays

Kind regards

Eric
0
 

Author Comment

by:Washcare
ID: 35069865
Eric

There are 60 columns, and after the code has run I am left with about 15203 rows.

Regards
0
 
LVL 6

Expert Comment

by:Eric Zwiekhorst
ID: 35070036
Hi Washcare,

with this code you load your data into a array
Dim shtrng(20000, 60) As Variant
Dim lastrow, i, j As Integer
 ActiveSheet.UsedRange.Rows.Count
 For i = 1 To lastrow
    For j = 1 To 60
        shtrng(i, j) = Cells(i, j)
    Next j
 next i


then you can run over the sheet again and paste the row whilst dissasembling columns W like shown above.
If you need me to re write the code I can do but only tomorrow. today I won't have anymore time to help...


Kr

Eric
0
 
LVL 6

Assisted Solution

by:Eric Zwiekhorst
Eric Zwiekhorst earned 800 total points
ID: 35070051
sorry little mistake

Dim shtrng(20000, 60) As Variant
Dim lastrow, i, j As Integer
 lastrow = ActiveSheet.UsedRange.Rows.Count
 For i = 1 To lastrow
    For j = 1 To 60
        shtrng(i, j) = Cells(i, j)
    Next j
 Next i


this is the correct code.

Kr Eric
0
 

Author Comment

by:Washcare
ID: 35070202
Eric

Thank you for your help, I am sorry but I do not fully understand how to use the above code, so if you could come back to me tomorrow. Have a good night.

Regards
0
 
LVL 18

Accepted Solution

by:
krishnakrkc earned 1200 total points
ID: 35071247
Hi,

Try this code.

Kris


Sub kTest()
    Dim x, k(), ka, i As Long, n As Long, j As Long, c As Long
    
    Const TotalCols As Long = 60
    Const SplitCol  As Long = 23 'W
    
    ka = ActiveSheet.UsedRange.Resize(, TotalCols)
    ReDim k(1 To UBound(ka, 1) * 15, 1 To TotalCols)
    
    For i = 1 To UBound(ka, 1)
        x = Split(ka(i, SplitCol), ";")
        For j = 0 To UBound(x) Step 2
            n = n + 1
            For c = 1 To UBound(ka, 2)
                If UBound(x) >= j + 1 Then
                    If c = SplitCol Then
                        k(n, c) = x(j) & ";" & x(j + 1)
                    Else
                        k(n, c) = ka(i, c)
                    End If
                Else
                    If c <> SplitCol Then
                        k(n, c) = ka(i, c)
                    Else
                        k(n, c) = x(j)
                    End If
                End If
            Next
        Next
    Next
    Range("a1").Resize(n, TotalCols).Value = k
End Sub

Open in new window

0
 

Author Closing Comment

by:Washcare
ID: 35072795
Thank you both, works amazingly!
0

Featured Post

On Demand Webinar: Networking for the Cloud Era

Did you know SD-WANs can improve network connectivity? Check out this webinar to learn how an SD-WAN simplified, one-click tool can help you migrate and manage data in the cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

722 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question