How do I get data in cells as an array up one row in the same column without selecting?

user_15150886 0
Viewed 83

I am trying to write a process that compares strings and deletes the duplicate string within a given column using a selection as the top and bottom constraints.

Most of the process of checking and deleting works however I am having trouble with moving the cell contents up a cell after the duplicate string was deleted.

Image showing how the script should work
enter image description here

Red outline is the loop that selects the String to compare against.
Green outline is the loop that finds, deletes and moves the cells up one.
Blue outline is the Selection.

Stage 1 is to find and compare two strings that are the same.
Stage 2 is to delete the string that is the same as the first string.
Stage 3 is to move everything under the deleted cell with the deleted string up one row so that there is no empty cell.

I'm having problems with stage 3. I don't know how to move all data in those cells up one row without using a loop and I can't use the selection.

Here is the code so far:

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
vba excel arrays
1 Answers

Unique (Remove Duplicates)

  • You could rather use one of the following.
  • The first solution will leave error values and blanks as part of the resulting data, while the second one will remove them.

The Code

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
user_98140690
Related