Merge data by macro

  • Thread starter Thread starter K
  • Start date Start date
K

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
 
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'
 
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
 
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
 
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
 
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
Click to expand...

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
 
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
Click to expand...

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
Click to expand...

I like moving down the column (or left-to-right across the row) whenever
possible... it just seem more natural to me.
 
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
 
Back
Top