View Single Post
  #8   Report Post  
Posted to microsoft.public.excel.programming
Bernd P Bernd P is offline
external usenet poster
 
Posts: 806
Default Merge data by macro

On 13 Mai, 17:03, "Rick Rothstein"
wrote:
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 (MVP - Excel)

"Rick Rothstein" wrote in message

...

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 (MVP - Excel)


"SteAXA" wrote in message
...
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'


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