如果发现重复，则复制相邻单元的VBA脚本 [英] VBA script to copy adjacent cells if duplicate found
问题描述
Excel 2010
我知道还有其他问题，但这是我正在使用的代码的具体问题。我一直在尝试修改这个VBA脚本，以适应我的目的，但到目前为止，我一直不成熟。
代码需要将重复值剪切并粘贴到同一行的另一列中。例如，如果在A2，A3，A4中有重复的，B3和B4的内容需要移动到C2和D2。
Sub CheckDupl（）
Dim x，i，nD As Integer
Dim c As String
Dim nLimit As Integer
Dim bFound As Boolean
nLimit = 6' - >你可以改变这个
nD = 2' - >开始行
对于x = 1到3
'Cells（x，6）=x
c = Cells（x，1）
bFound = False
对于n = x + 1到nLimit
如果不是单元格（n，6）=x然后
如果单元格（n，1）= c然后
如果不是bFound
bFound = True
单元格（nD，3）=单元格（x，2）
'单元格（nD，4）=单元格（x，3）
'单元格+ 1，3）=单元格（n，2）
单元格（nD，4）=单元格（n，2）
'单元格（n，6）=x
nD = nD
Else
'Cells（nD，5）=单元格（n，2）
单元格（nD，5）=单元格（n，2）
' 6）=x
nD = nD + 1
结束如果
结束如果
结束如果
下一个
下一个
End Sub
我已经做了我所需要的原则，但不会向下移动工作表。
那么哪里A行有一个副本，例如梨，A3和A4需要放在与该术语的第一个出现相同的行上 - 因此在这种情况下为C2和D2。范围相当长约1200行
我真的不能遵循你的代码，我犹豫下载工作簿，但我已经做了这个你可以调整：
Sub test（）
Dim lastRow As Integer，i As Integer
Dim cel As Range，rng As Range，sortRng As Range
Dim curString As String，nextString As String
Dim haveHeaders As Boolean
haveHeaders = False'如果您有标题，请将其更改为TRUE。
lastRow = Cells（1，1）.End（xlDown）.Row
如果hasHeaders然后'如果你有标题，我们将在第2行
设置rng =范围（单元格（2，1），单元格（lastRow，1））
设置sortRng =范围（单元格（2，1），单元格（lastRow，2））
Else
设置rng =范围（单元格（1，1），单元格（lastRow，1））
设置sortRng =范围（单元格（1，1），单元格（lastRow，2））
结束如果
'首先，让我们调用你的数据，按顺序获取所有的列A值，将所有重复的数据组合在一起
使用ActiveSheet
.Sort。 SortFields.Clear
.Sort.SortFields.Add Key：= rng，SortOn：= xlSortOnValues，Order：= xlAscending，DataOption：= xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
。应用
结束
'现在让我们将所有列B数据移动到重复的位置进入Col. C
'我们可以通过简单的计算出在rng
中显示的次数来检查单元格的值是否重复$ Dim DimDate为整型，firstInstanceRow为Integer ，lastInstanceRow As Integer
如果hasHeaders然后
curString = Cells（2，1）.Value
Else
curString = Cells（1，1）.Value
结束如果
Dim dupRng As Range'设置重复项的范围
Dim k As Integer
k = 0
对于i = 1 To lastRow
如果我> lastRow然后退出
单元格（i，1）。选择
curString = Cells（i，1）.Value
nextString = Cells（i + 1，1）.Value
isDuplicate = WorksheetFunction.CountIf（rng，Cells（i，1）.Value）
如果isDuplicate> 1然后
firstInstanceRow = i
直到细胞（i，1）.Offset（k，0）.Value<> nextString
'Cells（i，1）.Offset（k，0）.Select
lastInstanceRow = Cells（i，1）.Offset（k，0）.Row
k = k + 1
循环
范围（单元格（firstInstanceRow + 1，2），单元格（lastInstanceRow，2））。复制
单元格（firstInstanceRow，3）.PasteSpecial粘贴：= xlPasteAll，操作：= xlNone，SkipBlanks：= False，Transpose：= True
Application.CutCopyMode = False
范围（Rows（firstInstanceRow + 1），Rows（lastInstanceRow））EntireRow.Delete
k = 0
lastRow =单元格（1，1）.End（xlDown）.Row
结束如果
下一个i
结束
End Sub
这对我有效：我在列A和B中有数据：
注意：吨有报头。我使用Col.A作为具有可能的重复值的列。首先，它由A排，按顺序获得所有数字（或字母，如果按字母顺序排列）。这将重叠在一起。那么，它会查看列A中的每个单元格，如果该单元格的值超过1，则移动B信息。到C：
如果可以发布屏幕截图，或者只是让我知道你的数据在哪里，这可以很容易地被调整为包括更多的单元格，其他范围等。
编辑：快速的循环方式通过列，只是FYI：
Sub test（）
Dim rng As Range，cel As Range
rng =（A1：A100）
对于每个cel在rng
cel.Select
'在单元格中执行任何操作。完成之后，它将转到下一个
'我选择选择单元格，因为它帮助我调试时，以确保我选择了正确的单元格。你可以（应该）评论，当你知道它的作品。
下一个cel
End Sub
Excel 2010
I know there are other questions like this but this is a specific issue with the code I am using. I've been trying to modify this VBA script to suit my purposes but so far I've been unsuccesful. The code needs to cut and paste duplicate values into another column in the same row. eg if there are duplicates in A2,A3,A4 the contents of B3 and B4 need to move into C2 and D2.
Sub CheckDupl()
Dim x, i, nD As Integer
Dim c As String
Dim nLimit As Integer
Dim bFound As Boolean
nLimit = 6 '--> you can change this
nD = 2 '--> start row
For x = 1 To 3
'Cells(x, 6) = "x"
c = Cells(x, 1)
bFound = False
For n = x + 1 To nLimit
If Not Cells(n, 6) = "x" Then
If Cells(n, 1) = c Then
If Not bFound Then
bFound = True
Cells(nD, 3) = Cells(x, 2)
'Cells(nD, 4) = Cells(x, 3)
'Cells(nD + 1, 3) = Cells(n, 2)
Cells(nD, 4) = Cells(n, 2)
'Cells(n, 6) = "x"
nD = nD
Else
'Cells(nD, 5) = Cells(n, 2)
Cells(nD, 5) = Cells(n, 2)
'Cells(n, 6) = "x"
nD = nD + 1
End If
End If
End If
Next
Next
End Sub
I have made it do what I need in principle but it won't move down the worksheet. Here is a sample workbook. How can I make it loop through the column and only paste the row I need?
So where row A has a duplicate, pear for example, A3 and A4 need to be put on the same row as the first occurrence of that term - so C2 and D2 in this case. The range is quite long about 1200 rows
I wasn't really able to follow your code, and I am hesitant to download workbooks, but I have made this which you can tweak:
Sub test()
Dim lastRow As Integer, i As Integer
Dim cel As Range, rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = False ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(2, 1), Cells(lastRow, 2))
Else
Set rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2))
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do Until Cells(i, 1).Offset(k, 0).Value <> nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
How this works for me: I have data in Column A and B:
Note: I don't have headers. I used Col. A to be the column that has the possible duplicate values. First, it sorts by Col. A, to get all the numbers (or words, if alphabetical) in order. This will have all duplicates together. THen, it looks through each cell in column A, if there's more than 1 of that cell's value, move "B" info. to "C":
If you can post a screenshot, or just let me know where your data is, this can easily be tweaked to include more cells, other ranges, etc.
edit: quick way to loop through a column, just FYI:
Sub test()
Dim rng As Range, cel As Range
rng = ("A1:A100")
For Each cel In rng
cel.Select
' Do whatever in the cell. After this is done, it'll go to the next one
' I chose to Select the cell because it helps me when debugging, to make sure I selected the right cells. You can (should) comment that out when you know it works.
Next cel
End Sub
这篇关于如果发现重复，则复制相邻单元的VBA脚本的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
