Search code examples
excelcopy-pastetransposevba

excel vba copy value from a column and paste value in a cell

I have data like below. First column belongs to column A and second column belongs to column B. 

1   q
1   q
2   q
2   q
2   q
3   q

I would like to insert empty rows whenever values in column A change. To insert rows I am using the macro from this site. 

'select column a before running the macro
Sub InsertRowsAtValueChange()
'Update 20140716
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 2 Step -1
    If WorkRng.Cells(i, 1).Value <> WorkRng.Cells(i - 1, 1).Value Then
        WorkRng.Cells(i, 1).EntireRow.Insert
    End If
Next
Application.ScreenUpdating = True
End Sub

After that I would like to copy each set of values from column A and paste in a cell in column C. While pasting them, I would like to paste values in a cell in a row format (by concatenating them) and separating them by a space. In below case, cells c1 should have 1 1, cell c4 should have 2 2 2 and cell c8 should have 3

How to do this? I tried to record macro using first copying each set of values then pasting them after transposing into a row. But I am having hard time copying values again and pasting them within a single cell

Solution

  • The Before and After for code bellow:

    enter image description here enter image description here

    Option Explicit

Sub InsertRowsAtValueChange()
    Dim rng As Range, itms As Variant, cel As Range, i As Long, firstRow As Long

    Set rng = Range("A3:A1000")
    firstRow = rng.Row - 1

    Application.ScreenUpdating = False
    For i = rng.Rows.Count To 1 Step -1
        If rng.Cells(i, 1).Value2 <> rng.Cells(i - 1, 1).Value2 Then
            If i < rng.Row - 1 Then
                Set cel = rng(i, 1)
            Else
                rng.Cells(i, 1).EntireRow.Insert
                Set cel = rng(i + 1, 1)
            End If
            With cel.CurrentRegion
                itms = .Columns(1)
                If .Columns(1).Rows.Count > 1 Then itms = Join(Application.Transpose(itms))
                cel.Offset(0, 2) = itms
            End With
        End If
        If i = 1 Then Exit For
    Next
    Application.ScreenUpdating = True
End Sub