Swap values in Same Column Different Row ange

[peerogel]

Hello, I can't find a solution. I am trying to look through each value down a column, and compare the value to all other rows, in the same column, except to the one where it was found. If the value is not found on the compared row, take the original value in the column and swap it with the value located in the compared row.

The reason I am trying to do this, is to try and eliminate as many duplicates as possible within a row but keep the same values within the column. Not sure if there is an easier way to accomplish the same outcome. I also need to exclude (not move) some values, like: x, UFO, TRAIN, QUE, AL, SS, REV

Another example: The values are actually located between columns F and S and rows 30:112.

The value of F30 is "Test13" and it is not in row 37. So I would want to swap "Test15" for "Test13", however, "Test15" is already present in row 30 so, I want to skip that swap.

I don't want to swap X values, nor AL values so, I am skipping F31 and F32.

F35 value is "Test15". Row 33 does not contain "Test15" and Row 35 does not contain "Test13" so I would then want to switch those two values. Continue down all columns and rows trying to eliminate as many duplicates as possible within the row. If I keep going down the list the next swap would be H30 with H37 (Test14 with Test17).

Thanks in advance for any help.

https://drive.google.com/open?id=1JxU9m0mUM0hX-Um1DVqN_cgbuuMUdDA-

 

[peerogel]

This is where I am at right now. I am looping looking for the values but instead of getting the value of F30 and going through all the rows. I am getting the value of F30 and only looking through that row, then F31 and looking through that row and so on.

Sub GetColumns2()
Dim lnRow As Long, lnCol As Long
    Set ws = ThisWorkbook.Sheets("Test")
    With ws
    
        Set Rng = .Range("B30:B112")
        lastrow = .Range(Split(.Cells(, Rng.Column).Address, "$")(1) & _
               (Rng.Row + Rng.Rows.Count)).End(xlUp).Row
        'Debug.Print lastrow
    
    End With
    On Error Resume Next
For x = 6 To 19
For lnRow = 30 To lastrow
MyValue = Cells(lnRow, x).Value
lnCol = Sheet13.Cells(lnRow, 1).Worksheet.Range("F" & lnRow & ":S" & lnRow).Find(What:=MyValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
Debug.Print lnRow & vbCrLf & lnCol & vbCrLf & MyValue
lnCol = 0

Next lnRow
Next x
End Sub

 

[peerogel]

Getting there.. I locked it to the first row, not sure how to loop through the rest of the rows.

Sub GetColumns2()
Dim lnRow As Long, lnCol As Long
Dim movecell As String
    Set ws = ThisWorkbook.Sheets("G481 (2)")
    With ws
    
        Set Rng = .Range("B30:B112")
        lastrow = .Range(Split(.Cells(, Rng.Column).Address, "$")(1) & _
               (Rng.Row + Rng.Rows.Count)).End(xlUp).Row
        'Debug.Print lastrow
    
    End With
    On Error Resume Next
For x = 6 To 19
For lnRow = 30 To lastrow
MyValue = Cells(30, x).Value
'x, UFO, TRAIN, QUE, AL, SS, REV
If MyValue = MyValue = "X" Or MyValue = "AL" Or MyValue = "TIP" Or MyValue = "REV" Or MyValue = "QUE" Or MyValue = "UFO" Or MyValue = "SS" Then
GoTo NextRow
End If
lnCol = Sheet13.Cells(lnRow, 1).Worksheet.Range("F" & lnRow & ":S" & lnRow).Find(What:=MyValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
MySecondValue = Cells(lnRow, x).Value
                        'MsgBox lnRow & vbCrLf & lnCol & vbCrLf & MyValue
If lnCol = 0 Then
lnCol2 = Sheet13.Cells(30, 1).Worksheet.Range("F" & 30 & ":S" & 30).Find(What:=MySecondValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
        
        
  If MySecondValue = MySecondValue = "X" Or MySecondValue = "AL" Or MySecondValue = "TIP" Or MySecondValue = "REV" Or MySecondValue = "QUE" Or MySecondValue = "UFO" Or MySecondValue = "SS" Then
    
GoTo NextRow
Else
        If lnCol = 0 And lnCol2 = 0 Then ' MsgBox MyValue & vbCrLf & MySecondValue
  
    movecell = Cells(30, x).Value
    Cells(30, x).Value = Cells(lnRow, x).Value
    Cells(lnRow, x).Value = movecell
    'Exit Sub
        End If
            End If
lnCol2 = 0
Else
End If

lnCol = 0
NextRow:
Next lnRow
Next x
End Sub

 

[peerogel]

I got my idea sort..of working, But I am still getting a few duplicates within a row that I believe could be removed. I think that I need to add an 'if' formula stating that if the value is present more than three times and the row being looked at only has it once, then swap values... I think that will help get rid of more duplicates.

Sub GetColumns3()
Dim lnRow As Long, lnCol As Long
Dim movecell As String
    Set ws = ThisWorkbook.Sheets("G481 (2)")
    With ws
    
        Set Rng = .Range("B30:B112")
        lastrow = .Range(Split(.Cells(, Rng.Column).Address, "$")(1) & _
               (Rng.Row + Rng.Rows.Count)).End(xlUp).Row
        'Debug.Print lastrow
    
    End With
    On Error Resume Next
For x = 6 To 19
For i = 30 To lastrow
For lnRow = 30 To lastrow
MyValue = Cells(i, x).Value
'Cells(i, x).Select
If MyValue = "X" Or MyValue = "AL" Or MyValue = "TIP" Or MyValue = "REV" Or MyValue = "QUE" Or MyValue = "UFO" Or MyValue = "SS" Then GoTo NextRow2
End If
lnCol = Sheet13.Cells(lnRow, 1).Worksheet.Range("F" & lnRow & ":S" & lnRow).Find(What:=MyValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
MySecondValue = Cells(lnRow, x).Value
If lnCol = 0 Then
lnCol2 = Sheet13.Cells(i, 1).Worksheet.Range("F" & i & ":S" & i).Find(What:=MySecondValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
 
'MsgBox MyValue & vbCrLf & MySecondValue
        
   If MySecondValue = "X" Or MySecondValue = "AL" Or MySecondValue = "TIP" Or MySecondValue = "REV" Or MySecondValue = "QUE" Or MySecondValue = "UFO" Or MySecondValue = "SS" Then
GoTo NextRow
Else
    If lnCol = 0 And lnCol2 = 0 Then '
    movecell = Cells(i, x).Value
    Cells(i, x).Value = Cells(lnRow, x).Value
    Cells(lnRow, x).Value = movecell
        GoTo NextRow2
        End If
            End If
lnCol2 = 0
Else
End If

lnCol = 0
NextRow:
Next lnRow
NextRow2:
Next i
Next x
End Sub

 

[peerogel]

It is almost there. I am still getting a duplicates that can be easily removed not sure what I am doing wrong, I think burnt my last brain cell. I need a walk away and look at it again in a few to see if I can figure something out.

Sub GetColumns4()
Dim lnRow As Long, lnCol As Long
Dim movecell As String
    Set ws = ThisWorkbook.Sheets("test")
    With ws
    
        Set Rng = .Range("B30:B112")
        lastrow = .Range(Split(.Cells(, Rng.Column).Address, "$")(1) & _
               (Rng.Row + Rng.Rows.Count)).End(xlUp).Row
        'Debug.Print lastrow
    
    End With
    On Error Resume Next
For x = 6 To 19
For i = 30 To lastrow
For lnRow = 30 To lastrow
MyValue = Cells(i, x).Value

If MyValue = "X" Or MyValue = "AL" Or MyValue = "TIP" Or MyValue = "REV" Or MyValue = "QUE" Or MyValue = "UFO" Or MyValue = "SS" Then GoTo NextRow2
GoTo NextRow2
End If
lnCol = Sheet13.Cells(lnRow, 1).Worksheet.Range("F" & lnRow & ":S" & lnRow).Find(What:=MyValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
MySecondValue = Cells(lnRow, x).Value
If lnCol = 0 Then
lnCol2 = Sheet13.Cells(i, 1).Worksheet.Range("F" & i & ":S" & i).Find(What:=MySecondValue, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
 
        
If MyValue = "X" Or MyValue = "AL" Or MyValue = "TIP" Or MyValue = "REV" Or MyValue = "QUE" Or MyValue = "UFO" Or MyValue = "SS" Then GoTo NextRow2
      
GoTo NextRow
Else
    If lnCol = 0 And lnCol2 = 0 Or _
    (Application.WorksheetFunction.CountIf(ActiveSheet.Range("F" & lnRow & ":S" & lnRow), MyValue) >= 3 And _
     Application.WorksheetFunction.CountIf(ActiveSheet.Range("F" & i & ":S" & i), MySecondValue) <= 1) Then
 
    movecell = Cells(i, x).Value
    Cells(i, x).Value = Cells(lnRow, x).Value
    Cells(lnRow, x).Value = movecell
        GoTo NextRow2
        End If
            End If
                
lnCol2 = 0
Else
End If

lnCol = 0
NextRow:
Next lnRow
NextRow2:
Next i
Next x
End Sub

 

[peerogel]

Not pretty but I got it working. The only issue i see is that the top rows get less duplicates then the lower rows. The issue was with my CountIf/For statements.

    If lnCol = 0 And lnCol2 = 0 Or _
    (Application.WorksheetFunction.CountIf(ActiveSheet.Range("F" & i & ":S" & i), MyValue) >= 3 _
    And Application.WorksheetFunction.CountIf(ActiveSheet.Range("F" & lnRow & ":S" & lnRow), MySecondValue) <= 2) Then