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
|