حذف ستون های تکراری

Question

Dror یک کاربرگ دارد که حاوی اطلاعات بسیار کمی است. این امکان وجود دارد که داده های یک ستون دقیقاً مشابه داده های ستون دیگر باشد، بنابراین او نمی داند که آیا راه آسانی برای حذف ستون های تکراری در کاربرگ وجود دارد.

البته اولین قدم این است که بفهمیم دو ستون یکسان هستند یا نه. این را می توان به راحتی با فرمول آرایه ای مانند زیر تعیین کرد:

=AND(A1:A100=B1:B100)

(به یاد داشته باشید که یک فرمول آرایه با استفاده از Shift+Ctrl+Enter وارد می شود.) فرمول تمام مقادیر 100 ردیف اول ستون های A و B را با هم مقایسه می کند. اگر همه آنها یکسان باشند، فرمول TRUE را برمی گرداند. اگر هیچ یک از سلول ها مطابقت نداشته باشد، فرمول FALSE را برمی گرداند. اگر نتیجه درست است، می توانید یکی از ستون ها را حذف کنید، زیرا آنها یکسان هستند.

اگر چیزی می خواهید که کمی خودکارتر باشد، به این معنی که ستون تکراری حذف شود، باید از یک ماکرو استفاده کنید. مراحل زیر را از تمام ستون های کاربرگ می گذرانید و با شروع از سمت راست ترین ستون، همه ستون ها را با هم مقایسه می کنید. اگر هر کدام یکسان هستند - صرف نظر از ترتیب آنها در کاربرگ - پس ماکرو از شما می پرسد که آیا می خواهید ستون تکراری حذف شود.

Sub DeleteDuplicateColumns()
    Dim rngData As Range
    Dim arr1, arr2
    Dim i As Integer, j As Integer, n As Integer

    On Error Resume Next
    Set rngData = ActiveSheet.UsedRange
    If rngData Is Nothing Then Exit Sub

    n = rngData.Columns.Count

    For i = n To 2 Step -1
        For j = i - 1 To 1 Step -1
            If WorksheetFunction.CountA(rngData.Columns(i)) <> 0 And _
              WorksheetFunction.CountA(rngData.Columns(j)) <> 0 Then
                arr1 = rngData.Columns(i)
                arr2 = rngData.Columns(j)
                If AreEqualArr(arr1, arr2) Then
                    With rngData.Columns(j)
                        mark column to be deleted
                        .Copy
                        If MsgBox("Delete marked column?", vbYesNo) _
                          = vbYes Then
                            rngData.Columns(j).Delete
                        Else
                            remove mark
                            Application.CutCopyMode = False
                        End If
                    End With
                End If
            End If
        Next j
    Next i

End Sub

Function AreEqualArr(arr1, arr2) As Boolean
    Dim i As Long, n As Long
    AreEqualArr = False
    For n = LBound(arr1) To UBound(arr1)
        If arr1(n, 1) <> arr2(n, 1) Then
            Exit Function
        End If
    Next n
    AreEqualArr = True
End Function