Extract multiple data to other cells with same numbering

[fasty100]

Hi,
I have the following problem :
A=ID B
1 4 data
more data
even more data
2 5 data
more data
3 6 data
4 7 data
more data
The first numbers are just the row numbering from Excel, the second number
is an ID number I use , in colum B you will find the data about this ID
number, but I want for data, more data and even more data that it is put in
another row with the ID number in colum A, so i can create a tabel in acces
with this in it, now it does not work because you have more objects in 1 cel
So this schould be the result :
A=ID B
1 4 data
2 4 more data
3 4 even more data
4 5 data
5 5 more data
6 6 data
7 7 data
8 7 more data

How can I do this, so I can create a table in Acces
Thanks

 

[ryguy7272]

Ok, I think this is what you want. Please make a backup of your data before
running the code so you have something that is what you want in case the
solution I am offering does NOT do what you want:

Sub copyit()
Dim LastRow As Long
Dim myRange, MyRange1 As Range
LastRow = Cells(Rows.count, "A").End(xlUp).Row
For X = 1 To LastRow
For Y = 1 + X To LastRow
If Cells(X, 1).Value = Cells(Y, 1).Value Then
If MyRange1 Is Nothing Then
Set MyRange1 = Rows(Y).EntireRow
Rows(X).End(xlToRight).Offset(, 1).Value = Cells(Y, 2).Value
Else
Set MyRange1 = Union(MyRange1, Rows(Y).EntireRow)
Rows(X).End(xlToRight).Offset(, 1).Value = Cells(Y, 2).Value
End If
End If
Next
Next
MyRange1.Select
Selection.Delete
End Sub

 

[Rick Rothstein]

Give this macro a try...

Sub SplitDataLines()
Dim X As Long, LastRow As Long, Data() As String
Const FirstRow As Long = 1, DataCol As String = "B"
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
For X = LastRow To FirstRow Step -1
With Cells(X, DataCol)
Data = Split(.Value, vbLf)
If UBound(Data) Then
.Offset(1).Resize(UBound(Data)).EntireRow.Insert
.Resize(UBound(Data) + 1).Value = WorksheetFunction.Transpose(Data)
.Offset(, -1).Resize(UBound(Data) + 1).Value = .Offset(, -1).Value
End If
End With
Next
End Sub

 

[ryguy7272]

Rick, your macro didn't work for me, so I suspect my data-setup is wrong.
Fasty, maybe this is what you want:

Sub copyit()
Dim i As Long
Dim LastRow As Long

With Application

..ScreenUpdating = False
..Calculation = xlCalculationManual
End With

With ActiveSheet

LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1

If .Cells(i, "A").Value = .Cells(i - 1, "A").Value Then

..Cells(i, "C").Resize(, 100).Copy .Cells(i - 1, "D")
..Rows(i).Delete
End If
Next i

..Columns(2).Delete
End With

With Application

..Calculation = xlCalculationAutomatic
..ScreenUpdating = True
End With
End Sub

 

[Rick Rothstein]

I assumed the multiple lines shown for each ID were in the same cell
separated by Line Feed characters (rather than each line being on its own
row).