Public Sub Rearrange_HasWants()
Dim inputws As Worksheet, outputws As Worksheet
Dim datarange As Range
Dim i As Long, j As Long, Numberofrows As Long, rownum As Long, colnum As Long, ChainStartRow As Long, ChainEndRow As Long
Dim Has As String, Wants As String, Has2 As String, Wants2 As String, EmpID As String, PassedRows As String
Dim done As Boolean
Dim rearrangements As Integer
With Me
Set inputws = .Worksheets("Sheet2")
Set outputws = .Worksheets("Sheet3")
End With
outputws.Cells(2, 1).Resize(20, 30).ClearContents
inputws.Activate
Set datarange = [HasWants]
Maxrows = datarange.Rows.Count
datarange.Offset(, 2).Resize(, 1).ClearContents
' -------------------------------------------------------------------------------------------------------------------
' Start with cell A2
' Initialize i to 1 and Numberofrows to the maximum number of rows
' Each time a row of data is removed , Numberofrows will be decremented by 1
' -------------------------------------------------------------------------------------------------------------------
Columns("A:C").Select
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("B2:B108") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("A1:C108")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort above
rownum = 2
colnum = 1
i = 1
Numberofrows = Maxrows
Do While ((Numberofrows > 0) And (i <= Maxrows))
With datarange
Has = .Cells(i, 1).Value
Wants = .Cells(i, 2).Value
If Has = vbNullString Then GoTo LoopExit:
' -----------------------------------------------------------------------------------------------------------
' If there is data to be processed ,
' first save the current Has and Wants values in the variables SavedHas and SavedWants
' We maintain a string variable which keeps track of the rows we have passed while trying to find a match
' PassedRows is a string variable which will have the row number preceded and followed by an x ,
' so that there is no accidental match due to two consecutive digits such as 1 and 2 matching row 12
' as well as rows 1 and 2
' -----------------------------------------------------------------------------------------------------------
SavedHas = Has
SavedWants = Wants
If .Cells(i, 3) = 1 Then GoTo LoopExit:
PassedRows = "x" & CStr(i) & "x"
SavedRows = PassedRows
.Cells(i, 3).Value = 1
matchfound = False
Do
Swapped = False
For j = 1 To Maxrows
If .Cells(j, 3) <> 1 Then
CurrHas = .Cells(j, 1).Value
CurrWants = .Cells(j, 2).Value
If Not IsEmpty(CurrHas) Then
CurrRow = "x" & CStr(j) & "x"
If InStr(1, PassedRows, CurrRow) = 0 Then
If CurrHas = Wants And CurrWants = SavedHas Then
matchfound = True
Exit For
End If
If CurrHas = Wants Then
Has = CurrHas
Wants = CurrWants
Swapped = True
PassedRows = PassedRows & CurrRow
Exit For
End If
End If
End If
End If
Next
Loop Until (matchfound Or (Not Swapped))
If matchfound Then
Has = SavedHas
Wants = SavedWants
PassedRows = SavedRows
EmpID = .Offset(, -1).Cells(i, 1).Value
outputws.Cells(rownum, colnum).Value = EmpID & Chr(10) & Has
outputws.Cells(rownum, colnum + 1).Value = EmpID & Chr(10) & Wants
colnum = colnum + 2
.Cells(i, 1).Value = vbNullString
.Cells(i, 2).Value = vbNullString
.Cells(i, 3) = 1
Numberofrows = Numberofrows - 1
Do
Swapped = False
For j = 1 To Maxrows
If .Cells(j, 3) <> 1 Then
CurrHas = .Cells(j, 1).Value
CurrWants = .Cells(j, 2).Value
If Not IsEmpty(CurrHas) Then
CurrRow = "x" & CStr(j) & "x"
If InStr(1, PassedRows, CurrRow) = 0 Then
If CurrHas = Wants And CurrWants = SavedHas Then
EmpID = .Offset(, -1).Cells(j, 1).Value
outputws.Cells(rownum, colnum).Value = EmpID & Chr(10) & CurrHas
outputws.Cells(rownum, colnum + 1).Value = EmpID & Chr(10) & CurrWants
colnum = colnum + 2
.Cells(j, 1).Value = vbNullString
.Cells(j, 2).Value = vbNullString
.Cells(j, 3).Value = 1
Numberofrows = Numberofrows - 1
Swapped = False
Exit For
End If
If CurrHas = Wants Then
Has = CurrHas
Wants = CurrWants
Swapped = True
PassedRows = PassedRows & CurrRow
EmpID = .Offset(, -1).Cells(j, 1).Value
outputws.Cells(rownum, colnum).Value = EmpID & Chr(10) & Has
outputws.Cells(rownum, colnum + 1).Value = EmpID & Chr(10) & Wants
colnum = colnum + 2
.Cells(j, 1).Value = vbNullString
.Cells(j, 2).Value = vbNullString
.Cells(j, 3).Value = 1
Numberofrows = Numberofrows - 1
Exit For
End If
End If
End If
End If
Next
k = k + 1
Loop Until ((Not Swapped) Or (k >= Maxrows))
rownum = rownum + 1
colnum = 1
i = 1
Else '
If Len(PassedRows) > 4 Then
ChainStartRow = Val(Replace(Left(PassedRows, 4), "x", ""))
ChainEndRow = Val(Replace(Right(PassedRows, 4), "x", ""))
.Cells(ChainStartRow, 3).ClearContents
.Cells(ChainEndRow, 3).Value = 1
End If
i = 1
End If
LoopExit:
i = i + 1
End With
Loop
datarange.Offset(, 2).Resize(, 1).ClearContents
end sub
