VBA-Copy/Paste value to another column based on criteria

[BigBeachBananas]

Hi all,
I'm looking for a VBA that can search based on the criterion (male & female) in column A. I want to return all of the values in D to F and G based on gender. Please see attached for example. Thanks//

 

[bstory84]

You mentioned you wanted a VBA solution. However this can be done via formula.
Place in cell F2 and copy and paste down.

=IFERROR(INDEX($D:$D,SMALL(IF($A:$A="M",ROW($A:$A),""),ROW(F1)),1),"")

Place in cell G2 and copy and paste down.

=IFERROR(INDEX($D:$D,SMALL(IF($A:$A="F",ROW($A:$A),""),ROW(G1)),1),"")

But if you prefer VBA then this may do the job.

Option Explicit

Sub GetByGender()
Dim rng As Range
Dim rows As Long
Dim c As Variant
Dim i As Long
Dim mRow As Long
Dim fRow As Long

    'count used rows
    rows = ActiveSheet.UsedRange.rows.Count
    'set column A - Gender to perform loop search
Set rng = ActiveSheet.Range("A1", Cells(rows, 1))
    'set starting row #2 - skip headers
    mRow = 2
    fRow = 2
For Each c In rng
    If c = "M" Then
        'Male
        'column 6 = column F which is Males
        Cells(mRow, 6) = c.Offset(0, 3)
        mRow = mRow + 1
    ElseIf c = "F" Then
        'Female
        'column 7 = column G which is Females
        Cells(fRow, 7) = c.Offset(0, 3)
        fRow = fRow + 1
        
    Else
        'not designated - do nothing
    End If
Next c

MsgBox "Complete"

End Sub

 

[BigBeachBananas]

You mentioned you wanted a VBA solution. However this can be done via formula.
Place in cell F2 and copy and paste down.

=IFERROR(INDEX($D:$D,SMALL(IF($A:$A="M",ROW($A:$A),""),ROW(F1)),1),"")

Place in cell G2 and copy and paste down.

=IFERROR(INDEX($D:$D,SMALL(IF($A:$A="F",ROW($A:$A),""),ROW(G1)),1),"")

But if you prefer VBA then this may do the job.

Option Explicit

Sub GetByGender()
Dim rng As Range
Dim rows As Long
Dim c As Variant
Dim i As Long
Dim mRow As Long
Dim fRow As Long

    'count used rows
    rows = ActiveSheet.UsedRange.rows.Count
    'set column A - Gender to perform loop search
Set rng = ActiveSheet.Range("A1", Cells(rows, 1))
    'set starting row #2 - skip headers
    mRow = 2
    fRow = 2
For Each c In rng
    If c = "M" Then
        'Male
        'column 6 = column F which is Males
        Cells(mRow, 6) = c.Offset(0, 3)
        mRow = mRow + 1
    ElseIf c = "F" Then
        'Female
        'column 7 = column G which is Females
        Cells(fRow, 7) = c.Offset(0, 3)
        fRow = fRow + 1
       
    Else
        'not designated - do nothing
    End If
Next c

MsgBox "Complete"

End Sub

Thanks for both options