PDA

View Full Version : [SOLVED] Separate content of a cell (merged or not) in columns



brunoicq
10-13-2015, 08:28 PM
Hi

Weekly I receive a schedule with merged and not merged cells.

I have to separate all data in different columns. The final result should be like attached file.

Basically the data is the fisrt line of each cell, separated by "space". In the last column, I have to wrote all other lines (except the first).

PS: I'm using Excel 2007. I tried to attach images, but I'm a noob :(

HELP Please!!!

Jan Karel Pieterse
10-13-2015, 10:48 PM
This macro seems to do the trick:


Option Explicit
Sub ConvertTable()
Dim vData As Variant
Dim lRow As Long
Dim lTargetRow As Long
Dim lCol As Long
Dim lCol1 As Long
Dim oSh As Worksheet
Dim vNames As Variant
Dim sNames As String
Dim sPrevNames As String
ThisWorkbook.Worksheets.Add
Set oSh = ActiveSheet
vData = Range("A1:G5").Value
vNames = Split("Name,Place,Model,Country,Phase,Start,End,Description (all lines except the first)", ",")
oSh.Range("A1").Resize(, UBound(vNames) + 1).Value = vNames
For lRow = LBound(vData, 1) + 2 To UBound(vData, 1)
'Name Place Model Country Phase Start End Description (all lines except the first)
With oSh.Range("A1")
For lCol = 3 To UBound(vData, 2)
If Len(vData(lRow, lCol)) > 0 Then
sNames = Split(vData(lRow, lCol), Chr(10))(0)
sPrevNames = sNames
lTargetRow = lTargetRow + 1
.Offset(lTargetRow).Value = vData(lRow, 1)
.Offset(lTargetRow, 1).Value = vData(lRow, 2)
vNames = Split(sNames, " ")
.Offset(lTargetRow, 2).Value = vNames(0)
.Offset(lTargetRow, 3).Value = vNames(1)
.Offset(lTargetRow, 4).Value = vNames(2)
.Offset(lTargetRow, 5).Value = vData(2, lCol)
.Offset(lTargetRow, 6).Value = vData(2, lCol)
For lCol1 = lCol + 1 To UBound(vData, 2)
If Len(vData(lRow, lCol1)) > 0 Then
.Offset(lTargetRow, 6).Value = vData(2, lCol1)
Exit For
End If
Next
.Offset(lTargetRow, 7).Value = Replace(Replace(vData(lRow, lCol), sNames, ""), Chr(10), "")
End If
Next
End With
Next
End Sub

snb
10-14-2015, 01:40 AM
or


Sub M_snb()
Sheet1.Cells.UnMerge
sn = Sheet1.Cells(2, 1).CurrentRegion

With CreateObject("scripting.dictionary")
For j = 3 To UBound(sn)
For jj = 3 To UBound(sn, 2)
sq = Split(sn(j, jj))
For jjj = jj + 1 To UBound(sn, 2)
If sn(j, jjj) <> "" Then Exit For
Next
.Item(.Count) = Array(sn(j, 1), sn(j, 2), sq(0), sq(1), Split(sq(2), vbLf)(0), sn(2, jj), Format(sn(2, jjj - 1), "yyyy-mm-dd"), Split(sq(2), Split(sq(2), vbLf)(0) & vbLf)(1))
jj = jjj - 1
Next
Next

Cells(30, 1).Resize(.Count, 8) = Application.Index(.items, 0, 0)
End With
End Sub

mancubus
10-14-2015, 02:01 AM
@jkp

i think moving the vData assignment before the line which adds worksheet is necessary.
or, better imo,


vData = Worksheets("Scheduler").Range("A1:G5").Value

brunoicq
10-14-2015, 04:42 AM
Thanks everybody for the quick reply.

Both solutions are partially working.

The first solution has only a small issue about End Date. I attached a XLSM (Schedule-solution1.xlsm)

The second solution has a issue about Start and End date. I attached a XLSM (Schedule-solution2.xlsm)

I think solution1 is easier to fix

Jan Karel Pieterse
10-14-2015, 04:42 AM
Yes, you're right :-)

Jan Karel Pieterse
10-14-2015, 05:00 AM
Mine should have read:


Option Explicit
Sub ConvertTable()
Dim vData As Variant
Dim lRow As Long
Dim lTargetRow As Long
Dim lCol As Long
Dim lCol1 As Long
Dim oSh As Worksheet
Dim vNames As Variant
Dim sNames As String
Dim sPrevNames As String
vData = Range("A1:G5").Value
ThisWorkbook.Worksheets.Add
Set oSh = ActiveSheet
vNames = Split("Name,Place,Model,Country,Phase,Start,End,Description (all lines except the first)", ",")
oSh.Range("A1").Resize(, UBound(vNames) + 1).Value = vNames
For lRow = LBound(vData, 1) + 2 To UBound(vData, 1)
'Name Place Model Country Phase Start End Description (all lines except the first)
With oSh.Range("A1")
For lCol = 3 To UBound(vData, 2)
If Len(vData(lRow, lCol)) > 0 Then
sNames = Split(vData(lRow, lCol), Chr(10))(0)
sPrevNames = sNames
lTargetRow = lTargetRow + 1
.Offset(lTargetRow).Value = vData(lRow, 1)
.Offset(lTargetRow, 1).Value = vData(lRow, 2)
vNames = Split(sNames, " ")
.Offset(lTargetRow, 2).Value = vNames(0)
.Offset(lTargetRow, 3).Value = vNames(1)
.Offset(lTargetRow, 4).Value = vNames(2)
.Offset(lTargetRow, 5).Value = vData(2, lCol)
.Offset(lTargetRow, 6).Value = vData(2, lCol)
For lCol1 = lCol + 1 To UBound(vData, 2)
If Len(vData(lRow, lCol1)) > 0 Then
.Offset(lTargetRow, 6).Value = vData(2, lCol1)
Exit For
End If
Next
.Offset(lTargetRow, 7).Value = Replace(Replace(vData(lRow, lCol), sNames, ""), Chr(10), "")
End If
Next
End With
Next
End Sub

Jan Karel Pieterse
10-14-2015, 05:07 AM
Somehow I am unable to edit that previous post, Here is the corrected code:


Sub ConvertTable()
Dim vData As Variant
Dim lRow As Long
Dim lTargetRow As Long
Dim lCol As Long
Dim lCol1 As Long
Dim oSh As Worksheet
Dim vNames As Variant
Dim sNames As String
Dim sPrevNames As String
vData = Worksheets("Scheduler").Range("A1:G5").Value
ThisWorkbook.Worksheets.Add
Set oSh = ActiveSheet
vNames = Split("Name,Place,Model,Country,Phase,Start,End,Description (all lines except the first)", ",")
oSh.Range("A1").Resize(, UBound(vNames) + 1).Value = vNames
For lRow = LBound(vData, 1) + 2 To UBound(vData, 1)
With oSh.Range("A1")
For lCol = 3 To UBound(vData, 2)
If Len(vData(lRow, lCol)) > 0 Then
sNames = Split(vData(lRow, lCol), Chr(10))(0)
sPrevNames = sNames
lTargetRow = lTargetRow + 1
.Offset(lTargetRow).Value = vData(lRow, 1)
.Offset(lTargetRow, 1).Value = vData(lRow, 2)
vNames = Split(sNames, " ")
.Offset(lTargetRow, 2).Value = vNames(0)
.Offset(lTargetRow, 3).Value = vNames(1)
.Offset(lTargetRow, 4).Value = vNames(2)
.Offset(lTargetRow, 5).Value = vData(2, lCol)
.Offset(lTargetRow, 6).Value = vData(2, lCol)
For lCol1 = lCol + 1 To UBound(vData, 2)
If Len(vData(lRow, lCol1)) > 0 Then
.Offset(lTargetRow, 6).Value = vData(2, lCol1 - 1)
Exit For
ElseIf Len(vData(lRow, lCol1)) > 0 Or lCol1 = UBound(vData, 2) Then
.Offset(lTargetRow, 6).Value = vData(2, lCol1)
End If
Next
.Offset(lTargetRow, 7).Value = Replace(Replace(vData(lRow, lCol), sNames, ""), Chr(10), "")
End If
Next
End With
Next
End Sub

snb
10-14-2015, 05:50 AM
You changed the code; so you created the problem yourself.

brunoicq
10-14-2015, 06:43 AM
It works great!!!
Thank you sooooo much!