با سلام
لطفا کد زیر را بجای کد قبلی جایگزین کنید.
Sub Mir_Uniq_Value()
Dim lastColumn As Long
Dim Lastrow As Long
Lastrow = Sheet1.Cells(Rows.Count, "A").End(3).Row
lastColumn = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column / 2
DataCol = 1
DataRwo = 2
For i = 1 To lastColumn
Sheet1.Range(Cells(2, DataCol + 1), Cells(Lastrow, DataCol + 1)).ClearContents
For Each cell In Sheet1.Range(Cells(2, DataCol), Cells(Lastrow, DataCol))
NoOfCount = Application.WorksheetFunction.CountIfs(Sheet1.Columns(DataCol), cell.Value)
If NoOfCount = 1 Then
Cells(DataRwo, DataCol + 1) = cell.Value
DataRwo = DataRwo + 1
End If
Next
DataRwo = 2
DataCol = DataCol + 2
Next i
End Sub
سلامت باشید میر
