Creating multiple rows from multiple unique numbers contained in a single cell

michwdmn · Mar 20, 2017

Hi,

I'm trying to figure out some less painful ways of preparing a table so that it is ready for a spatial join to GIS data.

I'm working with a table that has unique entries based on permit number. But each permit number can apply to multiple claims. The claims are all contained in a single column (so for each permit, in a single cell).

What I would like is to separate out all of the claim numbers (I can do this by splitting to new columns) and then to have them as the unique entry (one row for each claim), with all of the relevant data duplicated for each claim that it applies to.

Simplification of existing table (it is much larger than this):

PERMIT	CLAIM	HOLDER	REGION	DATE	TYPE
p-1	12 52 76 98	ABC	NE	x	y
p-2	85 32 51 62 66 78 90	DEF	NE	x	y
p-3	59	GHI	NW	x	y
p-4	9 111 884 273 860 349 683 309 797 323 634 683 790 800	JKL	NW	x	y

What I'd like:

CLAIM	PERMIT	HOLDER	REGION	DATE	TYPE
15	p-1	ABC	NE	x	y
52	p-1	ABC	NE	x	y
76	p-1	ABC	NE	x	y
98	p-1	ABC	NE	x	y

So the resulting table will be much larger, having as many rows as there are unique claim numbers in the original table.

I started doing this by turning the claims cell into individual columns, and then copying those and transposing them in a new sheet. Then copying all the other data and pasting them beside each claim. This takes a long time given the size of the table and the number of claims that some permits apply to. Any tips are greatly appreciated.

Thanks

MickG · Mar 20, 2017

Try this for results on sheet2

Code:

[COLOR="Navy"]Sub[/COLOR] MG20Mar15
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 Ray = ActiveSheet.Range("A1").CurrentRegion
 ReDim nray(1 To 6, 1 To 1): c = 1
 nray(1, 1) = "Claim": nray(2, 1) = "Permit": nray(3, 1) = "Holder"
 nray(4, 1) = "Region": nray(5, 1) = "Date": nray(6, 1) = "Type"
 [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
        Sp = Split(Ray(n, 2), " ")
          [COLOR="Navy"]For[/COLOR] nn = 0 To UBound(Sp)
            c = c + 1
            ReDim Preserve nray(1 To 6, 1 To c)
             nray(1, c) = Sp(nn)
              nray(2, c) = Ray(n, 1)
               nray(3, c) = Ray(n, 3)
                nray(4, c) = Ray(n, 4)
                 nray(5, c) = Format(Ray(n, 5), "dd/mm/yyy")
                  nray(6, c) = Ray(n, 6)
            [COLOR="Navy"]Next[/COLOR] nn
 [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 6)
    .Value = Application.Transpose(nray)
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

NotoriousPopol · Mar 20, 2017

Hi,

you could use VBA and the function split to create an array of your numbers for each cell?

michwdmn · Mar 20, 2017

I'm not that familiar with excel beyond basic functions and pivot tables, unfortunately.

I'm using Excel 2007 for windows by the way.

MickG · Mar 20, 2017

Have a try with the below Information:-

To Save and Run Code:-
Copy code from Thread
In Your Data sheet , Click "Alt+F11",:- Vb Window appears.
From the VBWindow toolbar, Click "Insert" ,"Module":- New VBwindow appears .
Paste Code into this window.
Close Vbwindow.
On sheet Click "Developer tab", Click "Macro". Macro dialog box appears.
Select Macro (with same name) from List.
On the right of Dialog box Click "Run"
The Sheet should now be updated.
Regrds Mick

michwdmn · Mar 20, 2017

Thank you MickG.

I pasted it and made some changes (the example I gave was not quite identical to my table; foolish of me to do that).

Code:

Sub MG20Mar15()
Dim Ray As Variant, n As Long, nn As Long, Sp As Variant, c As Long
 Ray = ActiveSheet.Range("A1").CurrentRegion
 ReDim nray(1 To 8, 1 To 1): c = 1
 nray(1, 1) = "Claim": nray(2, 1) = "Permit": nray(3, 1) = "Holder"
 nray(4, 1) = "Townships": nray(5, 1) = "Type": nray(6, 1) = "Startdate": nray(7, 1) = "Enddate": nray(8, 1) = "Region"
 For n = 2 To UBound(Ray, 1)
        Sp = Split(Ray(n, 4), " ")
          For nn = 0 To UBound(Sp)
            c = c + 1
            ReDim Preserve nray(1 To 8, 1 To c)
             nray(1, c) = Sp(nn)
              nray(2, c) = Ray(n, 1)
               nray(3, c) = Ray(n, 3)
                nray(4, c) = Ray(n, 4)
                 nray(5, c) = Ray(n, 5)
                  nray(6, c) = Format(Ray(n, 6), "dd/mm/yyy")
                   nray(7, c) = Format(Ray(n, 7), "dd/mm/yyy")
                    nray(8, c) = Ray(n, 8)
            Next nn
 Next n
With Sheets("Sheet3").Range("A1").Resize(c, 8)
    .Value = Application.Transpose(nray)
    .Columns.AutoFit
    .Borders.Weight = 2
End With
End Sub

When I run it I get a "Run Time Error 13" Type Mismatch.

When I click debug it hi-lights the following line:
.Value = Application.Transpose(nray)

Any ideas?

Thanks again.

michwdmn · Mar 20, 2017

P.S. Here's a sample of what the actual table looks like.

michwdmn · Mar 20, 2017

Caught a mistake. Code now reads:

Code:

Sub MG20Mar15()
Dim Ray As Variant, n As Long, nn As Long, Sp As Variant, c As Long
 Ray = ActiveSheet.Range("A1").CurrentRegion
 ReDim nray(1 To 9, 1 To 1): c = 1
 nray(1, 1) = "Claim": nray(2, 1) = "Permit": nray(3, 1) = "Project"
 nray(4, 1) = "Holder": nray(5, 1) = "Townships":: nray(6, 1) = "Type": nray(7, 1) = "Startdate": nray(8, 1) = "Enddate": nray(9, 1) = "Region"
 For n = 4 To UBound(Ray, 1)
        Sp = Split(Ray(n, 4), " ")
          For nn = 0 To UBound(Sp)
            c = c + 1
            ReDim Preserve nray(1 To 9, 1 To c)
             nray(1, c) = Sp(nn)
              nray(2, c) = Ray(n, 1)
               nray(3, c) = Ray(n, 3)
                nray(4, c) = Ray(n, 4)
                 nray(5, c) = Ray(n, 5)
                  nray(6, c) = Ray(n, 6)
                   nray(7, c) = Format(Ray(n, 7), "dd/mm/yyy")
                    nray(8, c) = Format(Ray(n, 8), "dd/mm/yyy")
                     nray(9, c) = Ray(n, 9)
            Next nn
 Next n
With Sheets("Sheet3").Range("A1").Resize(c, 9)
    .Value = Application.Transpose(nray)
    .Columns.AutoFit
    .Borders.Weight = 2
End With
End Sub

But I get the same error.

Rick Rothstein · Mar 20, 2017

The data on your pictures is so small, I cannot make anything out on them. It kind of looks like your space delimited data is in Column F... if that is not correct, then change the red highlighted part of my code the correct column letter designation. The macro below rearranges your table in place, so make sure to test it out on a copy of your workbook until you are convinced it actually works with your data (as long as you specify the correct column and delimiter, a space in your case, I am convinced the code works correctly).

Code:

[table="width: 500"]
[tr]
	[td]Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, TableColumns As String, Data() As String
  Const Delimiter As String = " "
  Const DelimitedColumn As String = "[B][COLOR="#FF0000"]B[/COLOR][/B]"
  Const StartRow As Long = 2
  TableColumns = Range("A1", Cells(1, Columns.Count).End(xlToLeft)).EntireColumn.Address(0, 0)
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data = Split(Cells(X, DelimitedColumn), Delimiter)
    If UBound(Data) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn)) Then
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

MickG · Mar 20, 2017

Well your code runs , but you now have this:- Sp = Split(Ray(n, 4), " ")
Which is splitting the 4 column, but that not reflected in the "nn" loop"
Can you show an example of you current data ???

Creating multiple rows from multiple unique numbers contained in a single cell

michwdmn

New Member

Excel Facts

MickG

MrExcel MVP

NotoriousPopol

Board Regular

michwdmn

New Member

MickG

MrExcel MVP

michwdmn

New Member

michwdmn

New Member

michwdmn

New Member

Rick Rothstein

MrExcel MVP

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

Creating multiple rows from multiple unique numbers contained in a single cell

New Member

Excel Facts

MrExcel MVP

Board Regular

New Member

MrExcel MVP

New Member

New Member

New Member

MrExcel MVP

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock