[英]VBA excel: How do I get data in cells as an array up one row in the same column without selecting?
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 of how the script should work脚本应该如何工作的图像
Description for image图片说明
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 find and compare 2 strings that are the same第 1 阶段是查找并比较 2 个相同的字符串
Stage 2 is to delete the string that is the same as the first string.第 2 阶段是删除与第一个字符串相同的字符串。
Stage 3 is to move everything under the deleted cell with the deleted string up one row so that there is no empty cell.第 3 阶段是将已删除单元格下的所有内容与已删除字符串一起向上移动一行,以便没有空单元格。
Im Having problems with stage 3. I dont know how to move all data in those cells up one row without using a loop and I cant use the selection.我在第 3 阶段遇到问题。我不知道如何在不使用循环的情况下将这些单元格中的所有数据向上移动一行,而且我无法使用选择。
I have only been coding for a month now so some extra explanation would be grealty appreciated especially for arrays and objects.我现在只写了一个月的代码,所以非常感谢一些额外的解释,特别是对于 arrays 和对象。
Here is the script 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
thanks in advance for the help.在此先感谢您的帮助。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.