Macro to copy cell value if collumn contains a "t"

[Nenza]

Good morning,

I have an excel file, which contains property ID in column A and a value in column B. The IDs are repeated. I want to move the value to one row, so there will be no repetitions. Here is the data and here is what I want to achieve. I have made a helping column with value T, which appears if there is a duplicated ID in a column below. Could I ask with help on this?
Data:

Hotel	Concept identifier
AEAUH1YS	BB
AEAUH1YS	RO					t
AEDXBCNL	BB
AEDXBCNL	RO					t
AEDXBMAR	BB
AEDXBMAR	RO					t
AEDXBMED	BB
AEDXBMED	RO					t
AEDXBMOT	BB
AEDXBMOT	RO					t
AEDXBSLO	BB
AEDXBSLO	RO					t
AEFJRRST	BB
AEFJRRST	RO					t
AMEVN1	BB
AMEVN1	RO					t
ATLNZ1	BB
ATLNZ1	RO					t
ATSZGALT	BB
ATSZGALT	RO					t
ATVIESTY	BB
ATVIESTY	RO					t
AUNSSYDHST	BB
AUNSSYDHST	RO					t
AUNSSYDPLZ	BB
AUNSSYDPLZ	RO					t
AUVIMELFLG	BB
AUVIMELFLG	RO					t
AZBAK1	BB
AZBAK1	RO					t
BDCGPBAY	BB
BDDHAGAR	BB
BDDHAGAR	RO					t
BEANR1	BB
BEANR1	RO					t
BEANRAST	BB
BEANRAST	RO					t
BEANRBER	BB
BEANRBER	RO					t
BEBRUEUR	BB
BEBRUEUR	RO					t
BEBRUMID	BB
BEBRUMID	RO					t
BEBRUROY	BB
BEBRUROY	RO					t
BELEU1	BB
BELEU1	RO					t
BELGGAIR	BB
BELGGAIR	RO					t
BEQHA1	BB
BEQHA1	RO					t
BEQHAHAS	BB
BEQHAHAS	RO					t
BESPABAL	BB
BESPABAL	HB					t
BESPABAL	RO					t
BESPAPAL	BB
BHBAHDIP	BB
BHBAHDIP	RO					t
BNBWNDAR	BB
BNBWNDAR	RO					t
CAONIAG1	BB
CAONIAG1	RO					t
CGBZVMBA	BB
CGBZVMBA	RO					t
CHANDREU	BB
CHBSL1	BB
CHBSL1	RO					t
CHQGL1	BB
CHQGL1	RO					t
CHQLJ1	BB
CHQLJ1	HB					t
CHQLJ1	RO					t
CHZRHAR2	BB
CHZRHAR2	RO					t
CHZRHAR3	BB
CHZRHAR3	RO					t

And what I want:

Hotel	Concept identifier
AEAUH1YS	BB	RO
AEDXBCNL	BB	RO
AEDXBMAR	BB	RO
AEDXBMED	BB	RO
AEDXBMOT	BB	RO
AEDXBSLO	BB	RO
AEFJRRST	BB	RO
AMEVN1	BB	RO
ATLNZ1	BB	RO

 

[rollis13]

Have a try my macro. You don't need to use a help column (something's wrong with the BESPABAL hotel ) So, the best thing is that all the columns to the right of "B" be empty. This also means that there will be no limit to how many hotel repetitions are allowed. In case this isn't possible, in the macro you will find the changes to be made.

Option Explicit
Sub CompactDuplicates()
    Dim rw     As Long
    Dim cnt    As Long
    Application.ScreenUpdating = False
    With ActiveSheet
        .Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), Header:=xlYes 'sorts column A
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
            '--- if there is no data in columns after "B" then use -------------------------------------
            If .Cells(rw, 1) = .Cells(rw - 1, 1) Then
                cnt = cnt + 1
                .Cells(rw, 2).Resize(, cnt).Copy .Cells(rw - 1, Columns.Count).End(xlToLeft).Offset(, 1)
                .Cells(rw, 1).EntireRow.Delete
            Else
                cnt = 0
            End If
            '-------------------------------------------------------------------------------------------
            '--- else if there is data after column "B" limit the columns (as per your example "G") use ---
            'If .Cells(rw, 1) = .Cells(rw - 1, 1) Then
            '    .Cells(rw, 2).Resize(, 5).Copy .Cells(rw - 1, 7).End(xlToLeft).Offset(, 1)
            '    .Cells(rw, 1).EntireRow.Delete
            'End If
            '----------------------------------------------------------------------------------------------
        Next rw
    End With
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

 

[Marc L]

Hi, a VBA demonstration as a starter according to the initial attachment as it is - nothing wrong - where column G is useless :​

Sub Demo1()
    With [A1].CurrentRegion.Rows
        If .Count = 1 Or .Columns.Count > 2 Then Beep: Exit Sub
        With .Item("2:" & .Count):  V = .Value2:  .Clear:  End With
    End With
    With CreateObject("Scripting.Dictionary")
        For R& = 1 To UBound(V):  .Item(V(R, 1)) = .Item(V(R, 1)) & IIf(.Item(V(R, 1)) > "", vbTab, "") & V(R, 2):  Next
        [A2:B2].Resize(.Count) = Application.Transpose(Array(.Keys, .Items))
        [B2].Resize(.Count).TextToColumns [B2], xlDelimited, , , True
       .RemoveAll
    End With
End Sub