Re-organize data in Excel - I need help

[ina]

Hello,

I have a problem with Excel VBA. I would like to transform figure A in
Figure B

Figure A
A B C D
1 AA ABC
2 AA AC
3 AA DD
4 AA CD
5 AA CD
6 BB BBC
7 BB CC
8 BB BBC
9 BB CD
10 BB DE


Figure B
A B C D
1 AA ABC AC DD
2 AA CD
3 AA CD
4 BB BBC BBC DE
5 BB CC CD



I tried in several ways but still I did not get the figure B result.
Could someone help me on that issue?

regards,
Ina

 

[Bob Phillips]

Public Sub ProcessData()
Dim i As Long, j As Long
Dim iLastRow As Long
Dim iLastCol As Long
Dim sCheck As String

With ActiveSheet

Application.ScreenUpdating = False

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow - 1

sCheck = .Cells(i, "A").Value
For j = i + 1 To iLastRow

If .Cells(j, "A") <> sCheck Then
Exit For
End If
iLastCol = .Cells(j, .Columns.Count).End(xlToLeft).Column
If iLastCol > 1 And _
.Cells(i, iLastCol).Value = "" Then

.Cells(i, iLastCol).Value = .Cells(j, iLastCol).Value
.Cells(j, iLastCol).Value = ""
End If
Next j
Next i


For i = iLastRow To 1 Step -1
If Application.CountA(.Cells(i, "B").Resize(, 3)) = 0 Then
.Rows(i).Delete
End If
Next i

Application.ScreenUpdating = True
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[ina]

Public Sub ProcessData()
Dim i As Long, j As Long
Dim iLastRow As Long
Dim iLastCol As Long
Dim sCheck As String

With ActiveSheet

Application.ScreenUpdating = False

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow - 1

sCheck = .Cells(i, "A").Value
For j = i + 1 To iLastRow

If .Cells(j, "A") <> sCheck Then
Exit For
End If
iLastCol = .Cells(j, .Columns.Count).End(xlToLeft).Column
If iLastCol > 1 And _
.Cells(i, iLastCol).Value = "" Then

.Cells(i, iLastCol).Value = .Cells(j, iLastCol).Value
.Cells(j, iLastCol).Value = ""
End If
Next j
Next i

For i = iLastRow To 1 Step -1
If Application.CountA(.Cells(i, "B").Resize(, 3)) = 0 Then
.Rows(i).Delete
End If
Next i

Application.ScreenUpdating = True
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)











- Show quoted text -

Thank you so much. Really I've completely switched to another
direction.
Regards,
Ina

 

[Guest]

I get a diffferent answer than you got. Try this code and let me know if
changes are needed. It is not clear from your example when cells should and
should not be moved up to a higher row.

Sub combine()

RowCount = 1
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Do While RowCount <= LastRow
combineline = True
Do While (combineline = True) And _
(RowCount <= LastRow)
'test if next row is empty
combineline = False
emptycells = True
For colcount = 2 To 5
If Not IsEmpty(Cells(RowCount + 1, colcount)) Then
emptycells = False
Exit For
End If
Next colcount
If (emptycells = True) And _
(Cells(RowCount, "A") = _
Cells(RowCount + 1, "A")) Then
Rows(RowCount + 1).Delete
combineline = True
End If
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
If RowCount <= LastRow Then
If comparerow(RowCount) = True Then
For colcount = 1 To 5
If IsEmpty(Cells(RowCount, colcount)) And _
Not IsEmpty(Cells(RowCount + 1, colcount)) Then

Cells(RowCount + 1, colcount).Cut _
Destination:=Cells(RowCount, colcount)
combineline = True
End If
Next colcount
End If
End If
Loop
RowCount = RowCount + 1
Loop

End Sub
Function comparerow(ByVal RowCount As Long) As Boolean
'check if Myrow and MyRow + 1 can be combined
Match = True
Count = 0
For colcount = 1 To 5

If Len(Cells(RowCount, colcount)) > 0 Then
If Len(Cells(RowCount + 1, colcount)) > 0 Then
If Cells(RowCount, colcount) <> _
Cells(RowCount + 1, colcount) Then

Match = False
Exit For
End If
End If
End If
If Cells(RowCount, colcount) = "" Then
'count empty cells
Count = Count + 1
End If
Next colcount
If Count = 0 Then Match = False
comparerow = Match
End Function

 

[ina]

I get a diffferent answer than you got. Try this code and let me know if
changes are needed. It is not clear from your example when cells should and
should not be moved up to a higher row.

Sub combine()

RowCount = 1
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Do While RowCount <= LastRow
combineline = True
Do While (combineline = True) And _
(RowCount <= LastRow)
'test if next row is empty
combineline = False
emptycells = True
For colcount = 2 To 5
If Not IsEmpty(Cells(RowCount + 1, colcount)) Then
emptycells = False
Exit For
End If
Next colcount
If (emptycells = True) And _
(Cells(RowCount, "A") = _
Cells(RowCount + 1, "A")) Then
Rows(RowCount + 1).Delete
combineline = True
End If
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
If RowCount <= LastRow Then
If comparerow(RowCount) = True Then
For colcount = 1 To 5
If IsEmpty(Cells(RowCount, colcount)) And _
Not IsEmpty(Cells(RowCount + 1, colcount)) Then

Cells(RowCount + 1, colcount).Cut _
Destination:=Cells(RowCount, colcount)
combineline = True
End If
Next colcount
End If
End If
Loop
RowCount = RowCount + 1
Loop

End Sub
Function comparerow(ByVal RowCount As Long) As Boolean
'check if Myrow and MyRow + 1 can be combined
Match = True
Count = 0
For colcount = 1 To 5

If Len(Cells(RowCount, colcount)) > 0 Then
If Len(Cells(RowCount + 1, colcount)) > 0 Then
If Cells(RowCount, colcount) <> _
Cells(RowCount + 1, colcount) Then

Match = False
Exit For
End If
End If
End If
If Cells(RowCount, colcount) = "" Then
'count empty cells
Count = Count + 1
End If
Next colcount
If Count = 0 Then Match = False
comparerow = Match
End Function










- Show quoted text -

Thanks so much I willl testing it, I will give you updated. Thank
really.

ina

 

[ina]

Thanks so much I willl testing it, I will give you updated. Thank
really.
ina- Hide quoted text -

- Show quoted text

I tried it and it works perfectly. By the way, do you have any
suggestion for a good excel book programming? I would like to buy the
excel cookbook (O'really) but if you have another suggestion I will be
very welcome.
Ina