Merge data by macro

[K]

Hi all, I got data in column A and B as show below.

Row A B ......col
1 ID DATA ...headings
2 XY01 Record
3 Time
4 Left
5 XY02 Time
6 Right
7 XY03 System
8 Record
9 Time
10 Left

I need macro which should merge column B data and put result in column
C as shown below

Row A C ......col
1 ID DATA ...headings
2 XY01 Record Time Left
3
4
5 XY02 Time Right
6
7 XY03 System Record Time Left
8
9
10

Basically i need macro to go through column A cells and all those
cells in column B which have value and they are in

same row of blank cells of column A, macro should merge their values
and put result in column E in same row of non

blank cell of column A. Please can any friend can help me on this

 

[SteAXA]

I think that sub resolve what you need:

Sub MergeData()
Dim bEmptyColB As Boolean
Dim bNotEmptyColA As Boolean
Dim nCountRow As Integer
Dim sMergeStr As String

Range("A2").Select

bEmptyColB = False
nCountRow = 0
While Not bEmptyColB
If IsEmpty(ActiveCell.Offset(nCountRow, 1)) Then
bEmptyColB = True
Else
bNotEmptyColA = False
sMergeStr = ""
If IsEmpty(ActiveCell.Offset(nCountRow, 0)) Then
bNotEmptyColA = True
nCountRow = 0
End If
While Not bNotEmptyColA
If sMergeStr <> "" Then
sMergeStr = sMergeStr & " "
End If
sMergeStr = sMergeStr & ActiveCell.Offset(nCountRow, 1).Value
ActiveCell.Offset(nCountRow, 1).Value = ""
nCountRow = nCountRow + 1
If Not IsEmpty(ActiveCell.Offset(nCountRow, 0)) Then
bNotEmptyColA = True
ActiveCell.Offset(0, 1).Value = sMergeStr
ActiveCell.Offset(nCountRow, 0).Select
nCountRow = 0
Else
If IsEmpty(ActiveCell.Offset(nCountRow, 1)) Then
bNotEmptyColA = True
ActiveCell.Offset(0, 1).Value = sMergeStr
ActiveCell.Offset(nCountRow, 0).Select
nCountRow = 0
End If
End If
Wend
End If
Wend

End Sub

Bye, Ste'

 

[Rick Rothstein]

This is a lot shorter and should executer quicker...

Sub CombineData()
Dim X As Long, LastRow As Long, AnchorRow As Long
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
AnchorRow = 2
For X = AnchorRow + 1 To LastRow + 1
If Cells(X, "A").Value <> "" Or X = LastRow + 1 Then
Cells(AnchorRow, "B").Value = Join(WorksheetFunction.Transpose( _
Cells(AnchorRow, "B").Resize(X - AnchorRow)), " ")
Cells(AnchorRow + 1, "B").Resize(X - AnchorRow - 1).Clear
AnchorRow = X
End If
Next
End Sub

 

[Rick Rothstein]

Perhaps this is a better way to present my code (using a With/EndWith block
to reduce references)...

Sub CombineData()
Dim X As Long, LastRow As Long, AnchorRow As Long
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
AnchorRow = 2
For X = AnchorRow + 1 To LastRow + 1
If Cells(X, "A").Value <> "" Or X = LastRow + 1 Then
With Cells(AnchorRow, "B")
.Value = Join(Application.Transpose(.Resize(X - AnchorRow)), " ")
.Offset(1).Resize(X - AnchorRow - 1).Clear
End With
AnchorRow = X
End If
Next
End Sub

 

[K]

Thanks lot friends specially Rick as your code is shorter and works
perfect

 

[K]

Rick, If you dont mind can you please explain your 2nd macro in detail
that how it works as its just for my understanding. Thanks

 

[Bernd P]

Perhaps this is a better way to present my code (using a With/EndWith block
to reduce references)...

Sub CombineData()
  Dim X As Long, LastRow As Long, AnchorRow As Long
  LastRow = Cells(Rows.Count, "B").End(xlUp).Row
  AnchorRow = 2
  For X = AnchorRow + 1 To LastRow + 1
    If Cells(X, "A").Value <> "" Or X = LastRow + 1 Then
      With Cells(AnchorRow, "B")
        .Value = Join(Application.Transpose(.Resize(X - AnchorRow)), " ")
        .Offset(1).Resize(X - AnchorRow - 1).Clear
      End With
      AnchorRow = X
    End If
  Next
End Sub

Hello Rick,

Your Sub falls over for two adjacent rows with values in A.

My suggestion to correct for that:
Sub CombineData()
Dim X As Long, LastRow As Long, AnchorRow As Long
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
AnchorRow = 2
For X = AnchorRow + 1 To LastRow + 1
If Cells(X, "A").Value <> "" Or X = LastRow + 1 Then
If X - AnchorRow > 1 Then
With Cells(AnchorRow, "B")
.Value = Join(Application.Transpose(.Resize(X - AnchorRow)),
" ")
.Offset(1).Resize(X - AnchorRow - 1).Clear
End With
End If
AnchorRow = X
End If
Next
End Sub

Another approach (bottom - up):

Sub CombineData2()
Dim i As Long, lprev As Long
i = Cells(Rows.Count, 2).End(xlUp).Row
lprev = i + 1
Do
If Not IsEmpty(Cells(i, 1)) Then
If lprev - i > 1 Then
Cells(i, 2).Formula = Join(Application.Transpose(Cells(i,
2).Resize(lprev - i)), " ")
Cells(i + 1, 2).Resize(lprev - i - 1).ClearContents
End If
lprev = i
End If
i = i - 1
Loop While i > 1
End Sub

Regards,
Bernd

 

[Rick Rothstein]

See inline comments...

Your Sub falls over for two adjacent rows with values in A.

My suggestion to correct for that:
Sub CombineData()
Dim X As Long, LastRow As Long, AnchorRow As Long
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
AnchorRow = 2
For X = AnchorRow + 1 To LastRow + 1
If Cells(X, "A").Value <> "" Or X = LastRow + 1 Then
If X - AnchorRow > 1 Then
With Cells(AnchorRow, "B")
.Value = Join(Application.Transpose(.Resize(X - AnchorRow)),
" ")
.Offset(1).Resize(X - AnchorRow - 1).Clear
End With
End If
AnchorRow = X
End If
Next
End Sub

Good catch Bernd! Your suggested fix is how I would have done it also.

Another approach (bottom - up):

Sub CombineData2()
Dim i As Long, lprev As Long
i = Cells(Rows.Count, 2).End(xlUp).Row
lprev = i + 1
Do
If Not IsEmpty(Cells(i, 1)) Then
If lprev - i > 1 Then
Cells(i, 2).Formula = Join(Application.Transpose(Cells(i,
2).Resize(lprev - i)), " ")
Cells(i + 1, 2).Resize(lprev - i - 1).ClearContents
End If
lprev = i
End If
i = i - 1
Loop While i > 1
End Sub

I like moving down the column (or left-to-right across the row) whenever
possible... it just seem more natural to me.

 

[Rick Rothstein]

It is a little hard to know the detail I need to go into because I don't
know what parts of the code you already understand and what parts are
causing you to raise the question. However, I tried my best to explain
everything using Comments within the code. Note that I used Bernd's
modification to my originally posted code because he found a condition under
which my original code would fail and provided the appropriate fix for the
problem.

Sub CombineData()
' Always dimension all variables.
Dim X As Long, LastRow As Long, AnchorRow As Long
' Find the last row of data in Column B.
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
' The AnchorRow will be set and reset to the previous cell in
' Column A that had data in it. We do that so we will be able to
' figure out which cells in Column B need to be joined together. We
' start it at the cell in the first row of Column A with data in it.
AnchorRow = 2
' Since we know the first AnchorRow has data in Column A, we start
' our loop from the next row below it. The idea is to keep looping
' until we find the next cell in Column A with data in it. Once we
' find that, we know we must join the Column B cells from the
' AnchorRow to the row before the one we just found.
For X = AnchorRow + 1 To LastRow + 1
' Keep looping until we find a cell in Column A with data in it or
' until we reach the cell after the last piece of data in Column B.
' We need to do this last test because there will not be any data
' in Column A to stop our march downward.
If Cells(X, "A").Value <> "" Or X = LastRow + 1 Then
' As Bernd pointed out, we also need to ignore those cases where
' there are two data cells in Column A next to each other...
' there will be no cells in Column B to join in for that case.
' We need this test because the Transpose function will generate
' an error if we try to transpose a single cell.
If X - AnchorRow > 1 Then
' The With/End With block is a way to remove redundant object
' calls (whether that object is a range reference or some other
' object such as, for but one example, an ActiveX control. The
' way With/End With works is you put the object itself as the
' argument to the With statement, then you reference it methods
' or properties by using a "dot" in front of it. So, if you had
' Range("A1").Offset(1).Interior.ColorIndex referenced in your
' code, depending on what part of the object chain of property
' calls is repeated in other lines of code (this could be
' Range("A1") or Range("A1").Offset(1) or so on, you would put
' that repeated chain in the With part of the statement and use
' the dotted reference for statements between the With and
' End With statements which, for the above examples would be
' .Offset(1).Interior.ColorIndex or .Interior.ColorIndex and
' so on.
With Cells(AnchorRow, "B")
' Transpose takes a range of adjacent cells in a single column
' and makes it into a one-dimensional array which the VBA Join
' function can do its work on. We use the Resize property to
' expand the range to encompass all the cells from the AnchorRow
' to the row before the cell in Column A that had data in it and
' which cause the code to pass the If tests.
.Value = Join(Application.Transpose(.Resize(X - AnchorRow)), " ")
' We don't want to clear the cell we just put the joined data
' in, so we offset one from the current AnchorRow cell and
' adjust the Resize'd range to be one less... this means we
' reference all the cells we just joined except for the first
' one and Clear them.
.Offset(1).Resize(X - AnchorRow - 1).Clear
End With
End If
' Before we go onto the next iteration of the loop, we update the
' AnchorRow variable and make it equal to the current loop variable
' (which is the row where Column A has data in it).
AnchorRow = X
End If
Next
End Sub

 

[K]

thanks a lot for your time and help friends.