Retrieve and group multiple columns using VBA based on user entered criteria

[JaredXIII]

I am working making a primary sheet that retrieves data from other sheets automatically based on entries in certain cells using macros. My main sheet lists tasks, and my secondary sheet lists responsible party metadata (contact info, etc.). If a responsible party value is entered in a particular column in the main sheet, the macro searches the appropriate column in the second sheet, and if it finds it, copies all the data in the row and pastes it next to the entered value in the first sheet. It works to successfully retrieve the data from the first match it finds, but for some items there can be multiple matches. I need the code to retrieve all matches, insert new rows for each, and group them. Here is my code so far:

Sub Populate_System_Details()

    Dim WB As Workbook
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim x As String
    Dim y As String
    Dim WS1Range As Range
    Dim lastrow As Long
    
    Set WB = ActiveWorkbook
    Set WS1 = WB.Worksheets("Main")
    Set WS2 = WB.Worksheets("Sys_ref")
    lastrow = WS2.Range("A65536").End(xlUp).Row
    Set WS1Range = Range("F2:F" & lastrow)
    
    On Error GoTo ErrorHandler
    
    Application.ScreenUpdating = False
    
    'apply function to all cells in the F column
    For Each cell In WS1Range
        'get the selected cell's value
        y = cell.Value
        'get the selected cell's location
        x = cell.Address
        'if the cell is not blank, search for the value in second sheet
        If Not y = "" Then
            'find value in second sheet
            Set records = WS2.Range("B2:B" & lastrow).Find(y)
            'make sure second sheet is active
            Sheets("Sys_ref").Select
            'select the cell immediately to the right of cell where y value is found
            Sheets("Sys_ref").Range(records.Address(RowAbsolute:=False, ColumnAbsolute:=False)).Offset(0, 1).Select
            'from cell selected above, select all cells to the right with contents
            Range(Selection, Selection.End(xlToRight)).Select
            'copy the selection
            Selection.Copy
            'set first sheet as active
            Sheets("Main").Select
            'paste the copied data one cell to the right of the entered value
            ActiveSheet.Paste Destination:=WS1.Range(x).Offset(0, 1)
        End If
        'clear all cells to the right if the cell is blank
        If y = "" Then
            Sheets("Main").Select
            Sheets("Main").Range(x).Offset(0, 1).Select
            Range(Selection, Selection.End(xlToRight)).ClearContents
        End If
            
    Next cell
    
    Application.ScreenUpdating = True
    
ErrorHandler:
Select Case Err.Number
        'Common error: the specified text wasn't in the target worksheet.
        Case 9, 91
            Application.ScreenUpdating = True
            MsgBox "The value " & y & " was not found in Sys_ref"
        Exit Sub
        
        'General case: turn screenupdating back on, and exit.
        Case Else
            Application.ScreenUpdating = True
        Exit Sub
    End Select


End Sub

Is this reasonably viable? Thanks in advance for any help you can offer.

 

[pbornemeier]

This should work. I changed some sections. Please test/evaluate on copy of your data.

Option Explicit

Sub Populate_System_Details()

    Dim WB As Workbook
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim sCellAddress As String
    Dim sCellValue As String
    Dim WS1Range As Range
    Dim lWS1Lastrow As Long
    Dim lWS2Lastrow As Long
    Dim sFirstFindAddress As String
    Dim rngCell As Range
    Dim records As Object
    Dim lRowOffset As Long
    Dim lWS1ActiveRow As Long
    
    Set WB = ActiveWorkbook
    Set WS1 = WB.Worksheets("Main")
    Set WS2 = WB.Worksheets("Sys_ref")
    With WS2
        lWS2Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    With WS1
        lWS1Lastrow = .Cells(.Rows.Count, 6).End(xlUp).Row
    End With
    
    On Error GoTo ErrorHandler
    
    Application.ScreenUpdating = False
    
    'apply function to all cells in the F column
    For lWS1ActiveRow = lWS1Lastrow To 2 Step -1
        'get the selected cell's value
        sCellValue = WS1.Cells(lWS1ActiveRow, 6).Value
        'get the selected cell's location
        sCellAddress = WS1.Cells(lWS1ActiveRow, 6).Address
        'if the cell is not blank, search for the value in second sheet
        If Not sCellValue = "" Then
            'find value in second sheet
            'Set records = WS2.Range("B2:B" & lLastrow).Find(sCellValue) 'undefined Find parameters default
            '  to the values for the last Find done which may not be what you want.  next line is safer
            
            Set records = WS2.Range("B2:B" & lWS2Lastrow).Find(What:=sCellValue, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            If Not records Is Nothing Then
                sFirstFindAddress = records.Address
                Do
                    'process match
                
                    'Combine all into single row without needing to SELECT -- speeds processing
'                    'make sure second sheet is active
'                    Sheets("Sys_ref").Select
'                    'select the cell immediately to the right of cell where sCellValue value is found
'                    Sheets("Sys_ref").Range(records.Address(RowAbsolute:=False, ColumnAbsolute:=False)).Offset(0, 1).Select
'                    'from cell selected above, select all cells to the right with contents

'                    NEXT LINE COULD SELECT ENTIRE ROW IF CELLS RIGHT OF OFFSET CELL ARE EMPTY
'                    Range(records, Selection.End(xlToRight)).Select

'                    'copy the selection
'                    Selection.Copy
'                    'set first sheet as active
'                    Sheets("Main").Select
'                    'paste the copied data one cell to the right of the entered value
'                    ActiveSheet.Paste Destination:=WS1.Range(sCellAddress).Offset(0, 1)
                    
                    If lRowOffset > 0 Then WS1.Range(sCellAddress).Offset(lRowOffset, 0).EntireRow.Insert
                    WS2.Range(records.Offset(0, 1), WS2.Cells(records.Row, WS2.Cells(records.Row, WS2.Columns.Count).End(xlToLeft).Column)).Copy _
                        Destination:=WS1.Range(sCellAddress).Offset(lRowOffset, 1)
                    lRowOffset = lRowOffset + 1
                    
                    'look for next match
                    Set records = WS2.Range("B2:B" & lWS2Lastrow).FindNext(records)
                Loop While Not records Is Nothing And records.Address <> sFirstFindAddress
            End If

        End If
        'clear all cells to the right if the cell is blank
        If sCellValue = "" Then
            Sheets("Main").Select
            Sheets("Main").Range(sCellAddress).Offset(0, 1).Select
            Range(Selection, Selection.End(xlToRight)).ClearContents
        End If
        
        lRowOffset = 0
        
    Next lWS1ActiveRow
    
    Application.ScreenUpdating = True
    
    GoTo End_Sub
    
ErrorHandler:

Select Case Err.Number
        'Common error: the specified text wasn't in the target worksheet.
        Case 9, 91
            Application.ScreenUpdating = True
            MsgBox "The value " & sCellValue & " was not found in Sys_ref"
        Exit Sub
        
        'General case: turn screenupdating back on, display error and exit.
        Case Else
            Application.ScreenUpdating = True
            MsgBox "Error: " & Err.Number & vbLf & Err.Description, , "Unhandled Error"
        Exit Sub
    End Select
    
End_Sub:

End Sub

 

[JaredXIII]

Thanks for the reply, and from another Hampton Roads resident no less! It will take me some time to test this, as my focus has been diverted to a different project at the moment, but I will definitely put it to use as soon as possible and let you know if it works for what I need. Thanks again!