If conditions met, then move columns

Topic

New Reply

Hi,

Needs VBA code: In column C Id, if value is found repeated in the same column then check Column A & B if all three columns matched then move the data from Column D onwards to first Id, and delete that row whose data is moved to its matching columns.

Sample:

Reply | Quote

Replies

fjohan,

I believe this is what you are trying to achieve:

The code looks for matching rows by comparing Col A, B, and C. If match(s) found, the duplicate rows are deleted and their phone numbers are appended to the original. To speed the comparison and reduce looping, the code first sorts the data and compares the concatenation of columns A, B, and C for each Row.

HTH,
Maud

Before code ran:
38570-MatchID

After Code ran:
38571-MatchID2

Code:

Sub MatchID()
Application.ScreenUpdating = False
[COLOR=”#008000″]’———————————–
‘DECLARE AND SET VARIABLES[/COLOR]
Dim TestVal As String, CompareVal As String
Dim LastRow As Long, LastCol As Long
[COLOR=”#008000″]’———————————–
‘SORT BY INVOICE#, DESCRIPTION, ID[/COLOR]
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Range(“A1:H” & LastRow).Select
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“A2:A” & LastRow)
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“B2:B” & LastRow)
    ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“C2:C” & LastRow)
    With ActiveWorkbook.Worksheets(“Sheet1”).Sort
        .SetRange Range(“A1:H” & LastRow)
        .Header = xlYes
        .Apply
    End With
[COLOR=”#008000″]’———————————–
‘COMPARE ROWS AND LOOK FOR MATCH (CYCLE BACKWARDS)[/COLOR]
    For I = LastRow To 3 Step -1
        TestVal = Cells(I, 1) & Cells(I, 2) & Cells(I, 3)
        For J = I – 1 To 2 Step -1
            CompareVal = Cells(J, 1) & Cells(J, 2) & Cells(J, 3)
[COLOR=”#008000″]’———————————–
‘MATCH FOUND- APPEND PHONE AND DELETE MATCH ROW[/COLOR]
            If TestVal = CompareVal Then
                LastCol = ActiveSheet.Cells(I, Application.Columns.Count).End(xlToLeft).Column
                Cells(I, LastCol + 1) = Cells(J, 4)
                Cells.Rows(J).Delete
                I = I – 1
            Else:
                Exit For
            End If
        Next J
    Next I
Application.ScreenUpdating = True
End Sub

Reply | Quote

Thanks Maud,

Yes thats what i wanted, but for sample i had created that if A,B & C match then move to E column, infact there are chances that cell may contain data or may be the next one also so its better that we move to the empty cell instead of fixed cell.

Thanks in advance.

Reply | Quote

fjohan,

The code is not set to move to a fixed cell, It will move to the next available cell in the row therefore, it will accommodate any number of phone entries

Reply | Quote