vba to run a loop to pull out rows with certain ceriteria

[aliceinthewonderland]

Hi guys,

I have a set of data that I want to loop each row into the rest of the data, pull out a matching row if it appears in the rest of the data.

Criteria for matching rows: column A-C are identical but column D is different (column d only two choice of input: male, female)

I want to pull out matching pairs into another tab. The output should be an even number of rolls as they should be in pairs. once a matching row is found, the loop should stop as there may be another matching rows below but I only need one match for one row of data so each matching pair only contains 2 row of data.

So for example, first two rows are a pair as they have same group, city, school, class but opposite gender. Thank you guys!

Group	city	school	class	gender	my goal
A	city1	S1	C1	Female	include in output, as it is part of a matching pair
A	city1	S1	C1	Male	include in output, as it is part of a matching pair
A	city1	S1	C1	Male	not in output
B	city 2	S2	C1	Male	include in output, as it is part of a matching pair
B	city 2	S2	C1	Female	include in output, as it is part of a matching pair
C	city 2	S2	C1	Female	not in output

 

[Anthony47]

You should clarify whether your "matching pair" must include 1male + 1 female or gender isn't important

 

[aliceinthewonderland]

You should clarify whether your "matching pair" must include 1male + 1 female or gender isn't important

yes must have one male + one female

 

[Anthony47]

Try the following code, to be copied in a Standard vba module of your VbaProject:

Sub Pairs()
Dim wArr, tArr(), sSh As Worksheet, dSh As Worksheet
Dim I As Long, J As Long, tInd As Long, cLine As String
Dim oArr()
'
Set sSh = Sheets("Sheet1")      '<<< Sorce sheet
Set dSh = Sheets("Sheet2")      '<<< Destination sheet
'
With sSh
    wArr = .Range(.Range("A1"), .Range("A1").End(xlDown)).Resize(, 5).Value
End With
ReDim tArr(1 To UBound(wArr))
ReDim iArr(1 To UBound(wArr))
ReDim oArr(1 To 2)
For I = 2 To UBound(wArr)
    cLine = tJoin(wArr, I)
    tArr(I) = cLine
    iArr(I) = I
Next I
For I = 2 To UBound(tArr)
    cLine = tArr(I)
    mymatch = Application.Match(cLine, oArr, False)
    If IsError(mymatch) Then
        If InStr(1, cLine, "-male-", vbTextCompare) > 0 Then
            sline = Replace(cLine, "-male", "-Female", , , vbTextCompare)
        Else
            sline = Replace(cLine, "-Female", "-Male", , , vbTextCompare)
        End If
        mymatch = Application.Match(sline, tArr, False)
        If Not IsError(mymatch) Then
            cub = UBound(oArr)
            oArr(cub - 1) = cLine
            oArr(cub) = sline
            ReDim Preserve oArr(1 To cub + 2)
        End If
    End If
Next I
For I = 1 To cub
    mysplit = Split(oArr(I), "-", , vbTextCompare)
    For J = 0 To UBound(mysplit)
        wArr(I + 1, J + 1) = mysplit(J)
    Next J
Next I
dSh.Range("A1").CurrentRegion.ClearContents
dSh.Range("A1").Resize(cub + 1, UBound(wArr, 2)).Value = wArr
End Sub

Function tJoin(ByRef sArr, ByVal rInd As Long) As String
Dim J As Long, Tran As String
'
For J = 1 To UBound(sArr, 2)
    Tran = Tran & "-" & sArr(rInd, J)
Next J
tJoin = Mid(Tran, 2)
End Function

The lines marked <<< have to be compiled with your information

Beware that the destination sheet will be cleared from A1 to its "current region"; so if you use that sheet for additional data or formula make sure that ther is at least one free column between them and the area of the "matching pairs"

Try...

 

[DanteAmor]

Here is another macro for you to consider.
Data in sheet1 starting in cell A2, the output in sheet2 starting in cell A2.

Sub Making_pairs()
  Dim dic As Object
  Dim i As Long, j As Long, k As Long
  Dim a As Variant, b As Variant, ky As Variant
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  For i = 1 To UBound(a, 1)
    ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
    If Not dic.exists(ky) Then
      dic(ky) = 1 & "|" & a(i, 5)
    Else
      If Split(dic(ky), "|")(0) = 1 And Split(dic(ky), "|")(1) <> a(i, 5) Then
        j = j + 1
        For k = 1 To UBound(a, 2)
          If k = UBound(a, 2) Then b(j, k) = Split(dic(ky), "|")(1) Else b(j, k) = a(i, k)
          b(j + 1, k) = a(i, k)
        Next
        j = j + 1
        dic(ky) = 2 & "|" & a(i, 5)
      End If
    End If
  Next
  Sheets("Sheet2").Range("A2").Resize(j, UBound(b, 2)).Value = b
End Sub