group Rows based on a specific value in column

[Lisa4legin]

Hi
i have table of all different account numbers ,I am looking to export group of rows based on value in column D i:e value "3519" to create groups of rows which contain the part#3519 or #3519 to further export these to another sheet to build Invoices.
the other group or accounts not containing the specific "part#3519" can be discarded or not billed.

[Trebor76]

Hi Lisa,

Create a tab called Sheet2 and then run the following from Sheet1:

Option Explicit
Sub Macro1()
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        'Remove any existing filters
        .AutoFilterMode = False
        'Filter the data by the desired Part# with Col. C (not case sensitive)
        .Range("C1").AutoFilter Field:=3, Criteria1:="3519"
        .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) 'Copies the data to the next available row in Col. A of Sheet2. Change to suit.
        'Remove existing filter
        .AutoFilterMode = False 'Comment out this line if you want the filter left in place
    End With
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

[Lisa4legin]

Hi Lisa,

Create a tab called Sheet2 and then run the following from Sheet1:

Option Explicit
Sub Macro1()
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        'Remove any existing filters
        .AutoFilterMode = False
        'Filter the data by the desired Part# with Col. C (not case sensitive)
        .Range("C1").AutoFilter Field:=3, Criteria1:="3519"
        .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) 'Copies the data to the next available row in Col. A of Sheet2. Change to suit.
        'Remove existing filter
        .AutoFilterMode = False 'Comment out this line if you want the filter left in place
    End With
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

Hi Robert,
apparently the i am looking to export the group of rows along with the '3519' value row ,this code only filters out the rows that contain the "3519" value.. is there a workaround for this?

[FDibbins]

No VBA needed for this. Put this ARRAY formula on a new sheet A2, and copy down and across...

=IFERROR(INDEX(Sheet1!A:A,SMALL(IF(Sheet1!$C2:$C200=3519,ROW(Sheet1!A$2:A$200)),ROWS(Sheet1!F$2:F2))),"")

...confirmed by pressing CTRL+SHIFT+ENTER to activate the array, not just ENTER. You will know the array is active when you see curly braces { } appear around your formula. If you do not CTRL+SHIFT+ENTER you will get an error or a clearly incorrect answer. Press F2 on that cell and try again.

[Lisa4legin]

No VBA needed for this. Put this ARRAY formula on a new sheet A2, and copy down and across...

=IFERROR(INDEX(Sheet1!A:A,SMALL(IF(Sheet1!$C2:$C200=3519,ROW(Sheet1!A$2:A$200)),ROWS(Sheet1!F$2:F2))),"")

...confirmed by pressing CTRL+SHIFT+ENTER to activate the array, not just ENTER. You will know the array is active when you see curly braces { } appear around your formula. If you do not CTRL+SHIFT+ENTER you will get an error or a clearly incorrect answer. Press F2 on that cell and try again.

So this works exporting the 'Account#s into sheet2 , so how could I adapt this formula to rebuild the group (all columns) to the new sheet?

[FDibbins]

So this works exporting the 'Account#s into sheet2 , so how could I adapt this formula to rebuild the group (all columns) to the new sheet?

Change the range references to include the new sheet name. The formula is designed to allow you yo copy it down and across, it will pick up the other columns automatically

[Lisa4legin]

Change the range references to include the new sheet name. The formula is designed to allow you yo copy it down and across, it will pick up the other columns automatically

yes this works ..thanks a lot Ford!

[Trebor76]

Hi Robert,
apparently the i am looking to export the group of rows along with the '3519' value row ,this code only filters out the rows that contain the "3519" value.. is there a workaround for this?

I don't know what you mean

If you could re-post your workbook showing how the data would look before and after a macro, this should give me a better idea.

Thanks,

Robert

[Lisa4legin]

I don't know what you mean

If you could re-post your workbook showing how the data would look before and after a macro, this should give me a better idea.

Thanks,

Robert

Hi Robert,
please see , i have posted the sheet again as before and after files. So i was looking to export all the other parts along with the '3519' for a particular account.
these other parts are identified as having the same Account # and location-ID columns creating a group of parts for an account.
Explanation: The thing is that customers(account#) order the '3519' which is a premium service which we bill but we need to include the other parts also along on the invoice when billed.

[Trebor76]

Hi Lisa,

Try this where though it finds an extra group (refer account 29076493) I take it that's it's because of an oversight:

Option Explicit
Sub Macro1()

    Const lngStartRow As Long = 2 'Starting row number for the data. Change to suit.

    Dim rngCell As Range
    Dim varAccNum As Variant
    Dim lngMyRow As Long, _
        lngEndRow As Long, _
        lngPasteRow As Long
        
    lngEndRow = Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
    
    Application.ScreenUpdating = False

    For Each rngCell In Sheets("Sheet1").Range("C" & lngStartRow, Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp))
        If CStr(rngCell) = "3519" Then
            varAccNum = rngCell.Offset(0, -2)
            For lngMyRow = lngStartRow To lngEndRow
                If Sheets("Sheet1").Range("A" & lngMyRow) = varAccNum Then
                    On Error Resume Next 'Account for there being no data in Sheet2
                        lngPasteRow = Sheets("Sheet2").Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        If lngPasteRow = 0 Then lngPasteRow = lngStartRow
                    On Error GoTo 0
                    Sheets("Sheet1").Range("A" & lngMyRow & ":C" & lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & lngPasteRow)
                End If
            Next lngMyRow
        End If
    Next rngCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Process complete.", vbInformation

End Sub

Regards,

Robert

[Lisa4legin]

Hi Lisa,

Try this where though it finds an extra group (refer account 29076493) I take it that's it's because of an oversight:

Option Explicit
Sub Macro1()

    Const lngStartRow As Long = 2 'Starting row number for the data. Change to suit.

    Dim rngCell As Range
    Dim varAccNum As Variant
    Dim lngMyRow As Long, _
        lngEndRow As Long, _
        lngPasteRow As Long
        
    lngEndRow = Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
    
    Application.ScreenUpdating = False

    For Each rngCell In Sheets("Sheet1").Range("C" & lngStartRow, Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp))
        If CStr(rngCell) = "3519" Then
            varAccNum = rngCell.Offset(0, -2)
            For lngMyRow = lngStartRow To lngEndRow
                If Sheets("Sheet1").Range("A" & lngMyRow) = varAccNum Then
                    On Error Resume Next 'Account for there being no data in Sheet2
                        lngPasteRow = Sheets("Sheet2").Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        If lngPasteRow = 0 Then lngPasteRow = lngStartRow
                    On Error GoTo 0
                    Sheets("Sheet1").Range("A" & lngMyRow & ":C" & lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & lngPasteRow)
                End If
            Next lngMyRow
        End If
    Next rngCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Process complete.", vbInformation

End Sub

Regards,

Robert

hi Robert,
Nice ! thanks a lot..
just an after thought ...
is it possible to add more "values" to the group ,

 If CStr(rngCell) = "3519" Then

like "3501"
do i modify this line?

[Trebor76]

Hi Lisa,

Yes, you would additional part numbers to this line...

If CStr(rngCell) = "3519" Then

...like so for additional part numbers (you can have up to 30 individual part numbers):

If CStr(rngCell) = "3501" Or CStr(rngCell) = "3519" Then

Or you can use the following where each part number is separated by a comma ie 3519 for one part number or 3519,3501 for two (or how ever many part numbers you want) via the Inputbox function from the PartNumSelection macro:

Option Explicit
Sub PartNumSelection()

    Dim strMyArray() As String
    Dim intArrayItem As Integer
    
    strMyArray() = Split(InputBox("Enter the desired part number(s) each separated with a comma:", "Part Number Selection"), ",")
    
    'Quit if the <Cancel> button has been pressed
    If Len(Join(strMyArray)) = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    For intArrayItem = LBound(strMyArray) To UBound(strMyArray)
        PartNumExtraction (CStr(strMyArray(intArrayItem)))
    Next intArrayItem
    
    Application.ScreenUpdating = True
    
    MsgBox "Process complete.", vbInformation

End Sub
Sub PartNumExtraction(strPartNum As String)

    Const lngStartRow As Long = 2 'Starting row number for the data. Change to suit.

    Dim rngCell As Range
    Dim varAccNum As Variant
    Dim lngMyRow As Long, _
        lngEndRow As Long, _
        lngPasteRow As Long
        
    lngEndRow = Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row

    For Each rngCell In Sheets("Sheet1").Range("C" & lngStartRow, Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp))
        If CStr(rngCell) = strPartNum Then
            varAccNum = rngCell.Offset(0, -2)
            For lngMyRow = lngStartRow To lngEndRow
                If Sheets("Sheet1").Range("A" & lngMyRow) = varAccNum Then
                    On Error Resume Next 'Account for there being no data in Sheet2
                        lngPasteRow = Sheets("Sheet2").Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        If lngPasteRow = 0 Then lngPasteRow = lngStartRow
                    On Error GoTo 0
                    Sheets("Sheet1").Range("A" & lngMyRow & ":C" & lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & lngPasteRow)
                End If
            Next lngMyRow
        End If
    Next rngCell

End Sub

Regards,

Robert

[Lisa4legin]

Thanks Robert ! this really helps out appreciate your help!

[Trebor76]

You're welcome