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?
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