Find duplicate values between two columns and copy adjacent cells

Riseee

New Member
Joined
Oct 24, 2020
Messages
3
Office Version
  1. 2019
Platform
  1. Windows
Hi, I'm trying to check if there are any duplicates between columns C and M and if there are, I would like to take x number of cells adjacent to the duplicate (of column M) and bring them into the cells adjacent to the same duplicate in column C.
Example:
Cattura.PNG
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
No they are not always on the same row, the duplicates are in different columns and in random order.
Maybe "x" was too vague, let's say x=5. Let me give you another example, i feel like i didn't explain properly.
What i want to do is something like: if a value in column C is equal to a value in column M, then take 5 cells next to the duplicate in the column M and "paste" them into 5 cells next to the duplicate in column C.
Cattura.PNG
 
Upvote 0
This macro assumes you have headers in row 1 and your data starts in row 2.
VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, arr As Variant, x As Long, i As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Sheets("Sheet1")
        arr = .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).Value
        Set srcRng = .Range("M2", .Range("M" & .Rows.Count).End(xlUp))
        For i = LBound(arr) To UBound(arr)
            If Not IsError(Application.Match(arr(i, 1), srcRng, 0)) Then
                x = Application.Match(arr(i, 1), srcRng, 0)
                .Range("N" & x + 1).Resize(, 5).Cut .Range("D" & i + 1)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
Lookup Data

VBA Code:
Option Explicit

Sub lookupData()
    
' Constants
    
    Const srcName As String = "Sheet1"
    Const srcFirstCell As String = "M2"
    Const tgtName As String = "Sheet1"
    Const tgtFirstCell As String = "C2"
    Const NumOfDataCols As Long = 5
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
' Write values from ranges to arrays.
    
    Dim ws As Worksheet
    Dim First As Range
    Dim Last As Range
    Dim rng As Range

    ' Define Lookup Column Range ('rng') of Source Range.
    Set ws = wb.Worksheets(srcName)
    Set First = ws.Range(srcFirstCell)
    Set Last = ws.Cells(ws.Rows.Count, First.Column).End(xlUp)
    Set rng = ws.Range(First, Last)
    
    ' Write values from Lookup Column of Source Range
    ' to Source Lookup Array ('Lookup').
    Dim Lookup As Variant
    Lookup = rng.Value
    
    ' Write values from Data Columns of Source Range
    ' to Source Data Array ('Data').
    Dim Data As Variant
    Data = rng.Offset(, 1).Resize(, NumOfDataCols).Value
    
    ' Define Lookup Column Range ('rng') of Target Range.
    Set ws = wb.Worksheets(tgtName)
    Set First = ws.Range(tgtFirstCell)
    Set Last = ws.Cells(ws.Rows.Count, First.Column).End(xlUp)
    Set rng = ws.Range(First, Last)
    
    ' Write values from Lookup column of Target Range
    ' to Target Array ('Target').
    Dim Target As Variant
    Target = rng.Value
    ReDim Preserve Target(1 To UBound(Target, 1), 1 To NumOfDataCols)
    
    
' Write values from Source Array to Target Array.
    
    Dim CurrentValue As Variant
    Dim CurrentIndex As Variant
    Dim i As Long
    Dim j As Long
    
    For i = 1 To UBound(Target, 1)
        CurrentValue = Target(i, 1)
        CurrentIndex = Application.Match(CurrentValue, Lookup, 0)
        If Not IsError(CurrentIndex) Then
            For j = 1 To NumOfDataCols
                Target(i, j) = Data(CurrentIndex, j)
            Next j
        Else
            Target(i, 1) = Empty
        End If
    Next i
    
' Write values from Target Array to Target Range ('rng').
    
    Set rng = rng.Resize.Offset(, 1).Resize(, NumOfDataCols)
    rng.Value = Target
    
' Inform user.
    
    MsgBox "Data transferred.", vbInformation, "Success"

End Sub
 
Upvote 0
Both codes works perfectly, thank you very much you saved me a lot of time. Thanks you so much.
 
Upvote 0

Forum statistics

Threads
1,213,485
Messages
6,113,931
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top