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

[michwdmn]

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):

[TABLE="width: 500"]
<tbody>[TR]
[TD]PERMIT[/TD]
[TD]CLAIM[/TD]
[TD]HOLDER[/TD]
[TD]REGION[/TD]
[TD]DATE[/TD]
[TD]TYPE[/TD]
[/TR]
[TR]
[TD]p-1[/TD]
[TD]12 52 76 98[/TD]
[TD]ABC[/TD]
[TD]NE[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]p-2[/TD]
[TD]85 32 51 62 66 78 90[/TD]
[TD]DEF[/TD]
[TD]NE[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]p-3
[/TD]
[TD]59[/TD]
[TD]GHI[/TD]
[TD]NW[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]p-4[/TD]
[TD]9 111 884 273 860 349 683 309 797 323 634 683 790 800[/TD]
[TD]JKL[/TD]
[TD]NW[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
</tbody>[/TABLE]


What I'd like:
[TABLE="width: 500"]
<tbody>[TR]
[TD]CLAIM[/TD]
[TD]PERMIT[/TD]
[TD]HOLDER[/TD]
[TD]REGION[/TD]
[TD]DATE[/TD]
[TD]TYPE[/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]p-1[/TD]
[TD]ABC[/TD]
[TD]NE[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]52[/TD]
[TD]p-1[/TD]
[TD]ABC[/TD]
[TD]NE[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]76[/TD]
[TD]p-1[/TD]
[TD]ABC[/TD]
[TD]NE[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]98[/TD]
[TD]p-1[/TD]
[TD]ABC[/TD]
[TD]NE[/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
</tbody>[/TABLE]


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

 

[Rick Rothstein]

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).

[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]

So I said it looked like your data was in Column F, then I forgot to change the "B" that I highlighted in red to match what I wrote (the B is from the original code I wrote a while ago before I modified it for you). In any event, change that red letter to the column letter designation for the column containing your space delimited data.

 

[michwdmn]

Thank you Rick, this works (pretty much). It replaces most of the cells with "=R[-1]C" but it keeps one row intact from each, and it's much easier to just drag down than do what I was doing before.

P.S. I did upload a larger image in a subsequent post on page 1. Not sure if you saw it. The column was "D."

Regards

 

[michwdmn]

Thank you.

Is the image in Post#8 large enough to read? That is taken directly from the file I'm working on.

 

[Rick Rothstein]

Thank you Rick, this works (pretty much). It replaces most of the cells with "=R[-1]C" but it keeps one row intact from each, and it's much easier to just drag down than do what I was doing before.

Are you saying the formula "=R[-1]C" remains in the cells after my code finishes running? That should not be happening as I have code that is supposed to deliberately convert those formulas to constants. Any chance you can post a copy of your workbook with its existing data before any code is run against it to a file sharing service like OneDrive, DropBox, etc. so I can watch my code run in order to determine why it is not working correctly?

P.S. I did upload a larger image in a subsequent post on page 1. Not sure if you saw it. The column was "D."

Still not large enough to see. Apparently the browser shrinks the picture to fit the width of the web page and I cannot widen my browser enough to make that shrunken picture big enough to read. That should not matter because my code only needed to know the delimited column letter reference.

 

[michwdmn]

Thank you Rick,

Yes that is what happens.

I am not sure how to share with you unless you give me your email. I can only give you viewing privileges otherwise using dropbox.

 

[Rick Rothstein]

I am not sure how to share with you unless you give me your email. I can only give you viewing privileges otherwise using dropbox.

I'll private message it to you (because of my settings, you will not be able to private message me back, but of course you won't need to because you will have my email address).