Macro to extract 2 items for each branch

[howard]

I have data in Col A to Z from row2 onwards on sheet3

I have branch names in Col Y

I would like a macro to extract the first two items for each branch (data in Col A:Z) , except BR10 and paste these in row2 onwards on sheet4


Your assistance in this regard is most appreciated

 

[Yongle]

Try...

Option Explicit

Sub ExtractValues()
[COLOR=#808080][I]'variables and ranges[/I][/COLOR]
    Dim ws3 As Worksheet, ws4 As Worksheet, rng3 As Range, cel3 As Range, rng4 As Range, b As Range
    Dim Branches As New Collection, branch As Variant
    Set ws3 = Sheets("Sheet3")
    Set ws4 = Sheets("Sheet4")
    Set rng3 = ws3.Range("Y2", ws3.Range("Y" & Rows.Count).End(xlUp))
    Set rng4 = ws3.Cells(Rows.Count, "Y")
[COLOR=#808080][I]'create unique list of branches[/I][/COLOR]
    On Error Resume Next
        For Each cel3 In rng3
            If cel3 <> "BR10" Then Branches.Add CStr(cel3), CStr(cel3)
        Next
    On Error GoTo 0
[COLOR=#808080][I]'find each value and add to range to be copied[/I][/COLOR]
    For Each branch In Branches
        Set b = rng3.Find(branch, LookIn:=xlValues)
        Set rng4 = Union(rng4, b)
        If WorksheetFunction.CountIf(rng3, branch) > 1 Then Set rng4 = Union(rng4, rng3.FindNext(b))
        Set b = Nothing
    Next
[COLOR=#808080][I]'copy rows[/I][/COLOR]
    rng4.EntireRow.Copy ws4.Range("A2")
    Application.CutCopyMode = False
End Sub

 

[howard]

Thanks for the help. If I want to increase the range to 3 items per branch, where do I change this in your code ?

 

[Yongle]

Input box added for user to request number of rows per branch

Sub ExtractValues2()
'variables and ranges
    Dim ws3 As Worksheet, ws4 As Worksheet, rng3 As Range, cel3 As Range, rng4 As Range, b As Range
    Dim Branches As New Collection, branch As Variant, HowMany As Integer, H As Integer
    Set ws3 = Sheets("Sheet3")
    Set ws4 = Sheets("Sheet4")
    Set rng3 = ws3.Range("Y2", ws3.Range("Y" & Rows.Count).End(xlUp))
    Set rng4 = ws3.Cells(Rows.Count, "Y")
   [COLOR=#ff0000] HowMany = Application.InputBox("Copy How Many Entries", , 2, , , , , 1)[/COLOR]
[COLOR=#808080][I]'create unique list of branches[/I][/COLOR]
    On Error Resume Next
        For Each cel3 In rng3
            If cel3 <> "BR10" Then Branches.Add CStr(cel3), CStr(cel3)
        Next
    On Error GoTo 0
[I][COLOR=#808080]'find each value and add to range to be copied[/COLOR][/I]
    For Each branch In Branches
        Set b = rng3.Find(branch, LookIn:=xlValues)
        Set rng4 = Union(rng4, b)
       [COLOR=#ff0000] For H = 1 To HowMany - 1[/COLOR]
            If HowMany = 1 Then Exit For
            If WorksheetFunction.CountIf(rng3, branch) >= H Then
                Set b = rng3.FindNext(b)
                Set rng4 = Union(rng4, b)
            End If
        [COLOR=#ff0000]Next H[/COLOR]
        Set b = Nothing
    Next
[I][COLOR=#808080]'copy rows[/COLOR][/I]
    rng4.EntireRow.Copy ws4.Range("A2")
    Application.CutCopyMode = False
End Sub

 

[howard]

Thanks very much for your help

 

[Yongle]

Simpler code using CountIf

Sub ExtractValues3()
    Dim ws3 As Worksheet, ws4 As Worksheet, rng3 As Range, cel3 As Range, rng4 As Range
    Dim HowMany As Integer, H As Integer
    Set ws3 = Sheets("Sheet3")
    Set ws4 = Sheets("Sheet4")
    Set rng3 = ws3.Range("Y2", ws3.Range("Y" & Rows.Count).End(xlUp))
    Set rng4 = ws3.Cells(Rows.Count, "Y")
    HowMany = Application.InputBox("Copy How Many Entries", , 2, , , , , 1)

    For Each cel3 In rng3
        H = WorksheetFunction.CountIf(Range(rng3.Resize(1), cel3), cel3)
        If cel3 <> "BR10" And H <= HowMany Then Set rng4 = Union(rng4, cel3)
    Next
    
    rng4.EntireRow.Copy ws4.Range("A2")
    Application.CutCopyMode = False
End Sub

 

[howard]

Thanks for the updated simpler code

 

[Yongle]

You are welcome