VBA excel：如何在不選擇的情況下將單元格中的數據作為數組獲取到同一列中的一行？

Question

我正在嘗試編寫一個過程來比較字符串並使用選擇作為頂部和底部約束來刪除給定列中的重復字符串。 大多數檢查和刪除過程都有效，但是在刪除重復字符串后，我無法將單元格內容向上移動。

腳本應該如何工作的圖像

圖片說明

紅色輪廓是選擇要比較的字符串的循環

綠色輪廓是查找、刪除和向上移動單元格的循環。

藍色輪廓是選擇。

第 1 階段是查找並比較 2 個相同的字符串

第 2 階段是刪除與第一個字符串相同的字符串。

第 3 階段是將已刪除單元格下的所有內容與已刪除字符串一起向上移動一行，以便沒有空單元格。

我在第 3 階段遇到問題。我不知道如何在不使用循環的情況下將這些單元格中的所有數據向上移動一行，而且我無法使用選擇。

我現在只寫了一個月的代碼，所以非常感謝一些額外的解釋，特別是對於 arrays 和對象。

這是到目前為止的腳本：

Private Sub Tabeller()
Dim vRngMv As Variant
Dim iRowChsr1, iRowChsr2, iRowTtl, iI As Integer
Dim vRowIn, vRowComp As String
Dim oRngSlct, oRngMv As Range: Dim ws As Worksheet: Dim oBS As Object
'Newer Version will get rid of Selection as range determination

'Why does oRngSlct become a Variant/Object/Range here and oRngMv stays a Range object?
'I dont use it, kept it in to ask the question.
Set oRngMv = Selection: Set oRngSlct = Selection
iRowTtl = oRngSlct.Rows.Count

'First Loop For holding target cell data for comparison
For iRowChsr1 = 1 To iRowTtl
    'Chooses target cell and string
    vRowIn = oRngSlct(iRowChsr1, 1)
    'Second loop for Seeking a matching String
    For iRowChsr2 = 1 To iRowTtl
        'Check to not pick itself
        If iRowChsr1 = iRowChsr2 Then
            'Offsets Counter by 1 if it enocunters itself
            iRowChsr2 = iRowChsr2 + 1
        Else
            'Sets comparison string
            vRowComp = oRngSlct(iRowChsr2, 1)
            'String comparison
            iI = StrComp(vRowIn, vRowComp, 1)
            'If strings are equal
            If iI = 0 Then
            'Deletes; I know this is redundant but its here for clarity
                oRngSlct(iRowChsr2, 1) = ""
                'Offsets by iRowChsr by 1
                iRowChsr2 = iRowChsr2 + 1
                    'Create Variant with proper range, it just has to be translated into something that excel can move.
                    vRngMv = Range((oRngSlct(iRowChsr2, 1)), (oRngSlct(iRowTtl, 1)))
                    Set oRngMv = Range 'I know this doesnt work
                    'Offsets back to original Position of Deleted cell
                    iRowChsr2 = iRowChsr2 - 1
                    '*******************************
                    '*Cuts and pastes or moves here*
                    '*******************************
            End If
        End If
        'Next Comparison String
    Next iRowChsr2
    'Next target String
Next iRowChsr1

End Sub

在此先感謝您的幫助。

Answer 1

唯一（刪除重復項）

• 您可以使用以下之一。
• 第一個解決方案將保留錯誤值和空白作為結果數據的一部分，而第二個解決方案將刪除它們。

編碼

Option Explicit

Sub removeDupesColumnSelection()
    
    ' Validate Selection.
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    ' Remove duplicates.
    Selection.Columns(1).RemoveDuplicates Array(1), xlNo

End Sub

Sub uniquifyColumnSelection()
    
    ' Validate Selection.
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    ' Write values from first column of Selection to Data Array.
    Dim rg As Range: Set rg = Selection.Columns(1)
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim Data As Variant
    If rCount > 1 Then
        Data = rg.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
    End If

    ' In Unique Dictionary...
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        ' Write unique values from Data Array to Unique Dictionary.
        Dim Key As Variant
        Dim i As Long
        For i = 1 To rCount
            Key = Data(i, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = Empty
                End If
            End If
        Next i
        ReDim Data(1 To rCount, 1 To 1)
        If .Count > 1 Then
            ' Write values from Unique Dictionary to Data Array.
            i = 0
            For Each Key In .Keys
                i = i + 1
                Data(i, 1) = Key
            Next Key
        End If
    End With

    ' Write values from Data Array to Destination Range.
    rg.Value = Data

End Sub