VBA: Insert row/rows with data from another sheet if cell value matches specific value

[gaganji143]

Hi,

My name is Gagan and I am new to this forum. I request your help me in creating a macro which gets triggered once the user completes entering a value(Yes) in column K. Click here Source file. User sheet is the working sheet where the data will be populated. The source file is the mother file from where data will be fetched.

The first column contains either "H" or "D", "H" is for header details, which is entered by the user. "D" is the details which get populated below each Header row based on below criteria.
The key is the P Type on Header record ("H").
If it is "M – Material", it should create Detail records ("D") for Source file.P_Type = "B – Both" and "M – Material".
If it is "S – Services", it should create Detail records ("D") for Source file.P_Type = "B – Both" and "S – Services".
If it is "F – Feed", it should create Detail records ("D") for Source file.P_Type = "F – Feed"
Please let me know if you have any questions.

Regards
Gagan

 

[John_w]

Welcome to MrExcel.

Received your PM - I don't usually spend so much time on PM requests, and it was quite a bit of work to code this, and it might not work exactly as you require. I'm not sure from your description whether the User sheet and Source file sheet are in separate workbooks, or the same workbook. The code assumes the latter, since that is what you provided. Also, the macro only puts data in rows below existing data in the User sheet; so in the workbook you provided the user is expected to type in a "H" header record in row 78, and when Yes is put in K78, the macro copies data values from the Source file sheet to rows 79 and below in the User sheet.

Put this code in the sheet module for "User sheet":

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim UserData As Variant
    
    If Target.Cells.Count = 1 And Target.Column = Columns("K").Column Then
        If Cells(Target.row, "A").Value = "H" And Target.Value = "Yes" Then
            
            Application.EnableEvents = False
            
            Select Case Cells(Target.row, "D").Value
            
                Case Is = "M - Material"
                    UserData = Get_User_Data(Array("B - Both", "M - Material"), ThisWorkbook.Worksheets("Source File"))
                    Cells(Target.row + 1, "A").Resize(UBound(UserData), UBound(UserData, 2)).Value = UserData

                Case Is = "S - Services"
                    UserData = Get_User_Data(Array("B - Both", "S - Services"), ThisWorkbook.Worksheets("Source File"))
                    Cells(Target.row + 1, "A").Resize(UBound(UserData), UBound(UserData, 2)).Value = UserData
                    
               Case Is = "F - Feed"
                    UserData = Get_User_Data(Array("F - Feed"), ThisWorkbook.Worksheets("Source File"))
                    Cells(Target.row + 1, "A").Resize(UBound(UserData), UBound(UserData, 2)).Value = UserData
                    
            End Select
            
            Application.EnableEvents = True
            
        End If
    End If
    
End Sub

Put this code in a standard module:

Option Explicit

Public Function Get_User_Data(P_Types As Variant, SourceFileSheet As Worksheet) As Variant

    Dim FilteredData As Variant
    Dim UserData() As Variant
    Dim i As Long
    
    With SourceFileSheet
    
        'Filter specified sheet column C (P Type) on the specified P_Type(s)
        
        .UsedRange.AutoFilter Field:=3, Criteria1:=P_Types, Operator:=xlFilterValues, VisibleDropDown:=True
        
        'Put visible filtered data in a 2D array.  Row 1 of this array contains the column headings
        
        FilteredData = Get_Filtered_Rows(.AutoFilter.Range.SpecialCells(xlCellTypeVisible))

        'Clear filter on column C
        
        .UsedRange.AutoFilter Field:=3
        
    End With
    
    'Copy filtered data array from row 2 (to omit column headings) to another array with the column values in required order for User sheet
      
    ReDim UserData(1 To UBound(FilteredData), 1 To 10)
    For i = 2 To UBound(FilteredData)
        UserData(i - 1, 1) = "D"
        UserData(i - 1, 2) = "Standard"
        UserData(i - 1, 3) = FilteredData(i, 4)
        UserData(i - 1, 4) = "Y"
        UserData(i - 1, 5) = FilteredData(i, 3)
        UserData(i - 1, 6) = FilteredData(i, 9)
        UserData(i - 1, 7) = FilteredData(i, 8)
        UserData(i - 1, 8) = FilteredData(i, 1)
        UserData(i - 1, 9) = FilteredData(i, 7)
        UserData(i - 1, 10) = FilteredData(i, 2)
    Next
    
    'Return array to caller
    
    Get_User_Data = UserData
  
End Function


Private Function Get_Filtered_Rows(source As Range) As Variant
    
    Dim area As Range
    Dim i As Long
    Dim numRows As Long, numColumns As Long
    Dim r As Long, c As Long, destRow As Long
    Dim areasArray() As Variant
    Dim outputArray() As Variant
    
    'Create an array of 2D arrays.  Each 2D array contains the values from the filtered areas
    
    ReDim areasArray(1 To source.Areas.Count)
    For i = 1 To source.Areas.Count
        Set area = source.Areas(i)
        areasArray(i) = area.Value
        numRows = numRows + area.Rows.Count
    Next
    numColumns = area.Columns.Count
    
    'Copy values from each 2D area to a 2D output array
    
    ReDim outputArray(1 To numRows, 1 To numColumns) As Variant
    destRow = 0
    For i = 1 To UBound(areasArray, 1)
        For r = 1 To UBound(areasArray(i), 1)
            destRow = destRow + 1
            For c = 1 To numColumns
                outputArray(destRow, c) = areasArray(i)(r, c)
            Next
        Next
    Next
    
    Get_Filtered_Rows = outputArray
    
End Function

 

[gaganji143]

Thanks a lot John! Script works flawlessly.

 

[gaganji143]

Hi John,

The solution provided by you worked perfectly fine. But now a little change is required in VBA execution.
Now the requirement has changed to that the user enters all Header rows ( Rows with ‘H’ in First Column ) at once and afterward they can come back and do a mass “Yes”, the macro should then pull the columns applicable to the respective header procurement type. The previous file can be found here.

Thanks in advance.

 

[John_w]

Change the code in the ProjectSupplyChainAssignmentSch sheet module to:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim firstRow As Long, lastRow As Long
    Dim r As Long
    Dim UserData As Variant
    Dim SCASsheet As Worksheet
    
    If Target.Column <> Range("K1").Column Then Exit Sub
    
    Set SCASsheet = Worksheets("SCAS Columns")
    
    firstRow = Target.Row
    lastRow = Target.Row + Target.Rows.Count - 1
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    r = firstRow
    While r <= lastRow
    
        If Cells(r, "A").Value = "H" And Cells(r, "K").Value = "Yes" Then
    
            Select Case Cells(r, "D").Value
            
                Case Is = "M - Material"
                    UserData = Get_User_Data(Array("B - Both", "M - Material"), SCASsheet)
                    Rows(r + 1).Resize(UBound(UserData)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Rows(r + 1).Resize(UBound(UserData)).ClearFormats
                    Cells(r + 1, "A").Resize(UBound(UserData), UBound(UserData, 2)).Value = UserData
                    r = r + UBound(UserData)
                    lastRow = lastRow + UBound(UserData)
                    
                Case Is = "S - Services"
                    UserData = Get_User_Data(Array("B - Both", "S - Services"), SCASsheet)
                    Rows(r + 1).Resize(UBound(UserData)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Rows(r + 1).Resize(UBound(UserData)).ClearFormats
                    Cells(r + 1, "A").Resize(UBound(UserData), UBound(UserData, 2)).Value = UserData
                    r = r + UBound(UserData)
                    lastRow = lastRow + UBound(UserData)
                    
               Case Is = "F - Feed"
                    UserData = Get_User_Data(Array("F - Feed"), SCASsheet)
                    Rows(r + 1).Resize(UBound(UserData)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Rows(r + 1).Resize(UBound(UserData)).ClearFormats
                    Cells(r + 1, "A").Resize(UBound(UserData), UBound(UserData, 2)).Value = UserData
                    r = r + UBound(UserData)
                    lastRow = lastRow + UBound(UserData)
            
            End Select
            
        End If
            
        r = r + 1
    
    Wend
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

There is a tiny change to the code in the standard module:

ReDim UserData(1 To UBound(FilteredData)[B][COLOR=#ff0000] - 1[/COLOR][/B], 1 To 10)

The complete code in the standard module is:

Option Explicit

Public Function Get_User_Data(P_Types As Variant, SCASsheet As Worksheet) As Variant

    Dim FilteredData As Variant
    Dim UserData() As Variant
    Dim i As Long
    
    With SCASsheet
    
        'Filter specified sheet column C (P Type) on the specified P_Type(s)
        
        .UsedRange.AutoFilter Field:=3, Criteria1:=P_Types, Operator:=xlFilterValues, VisibleDropDown:=True
        
        'Put visible filtered data in a 2D array.  Row 1 of this array contains the column headings
        
        FilteredData = Get_Filtered_Rows(.AutoFilter.Range.SpecialCells(xlCellTypeVisible))

        'Clear filter on column C
        
        .UsedRange.AutoFilter Field:=3
        
    End With
        
    'Copy filtered data array from row 2 (to omit column headings) to another array with the column values in required order for User sheet
      
    ReDim UserData(1 To UBound(FilteredData) - 1, 1 To 10)
    For i = 2 To UBound(FilteredData)
        UserData(i - 1, 1) = "D"
        UserData(i - 1, 2) = "Standard"
        UserData(i - 1, 3) = FilteredData(i, 4)
        UserData(i - 1, 4) = "Y"
        UserData(i - 1, 5) = FilteredData(i, 3)
        UserData(i - 1, 6) = FilteredData(i, 9)
        UserData(i - 1, 7) = FilteredData(i, 8)
        UserData(i - 1, 8) = FilteredData(i, 1)
        UserData(i - 1, 9) = FilteredData(i, 7)
        UserData(i - 1, 10) = FilteredData(i, 2)
    Next
    
    'Return array to caller
    
    Get_User_Data = UserData
  
End Function


'http://www.vbforums.com/showthread.php?802353-RESOLVED-Copy-Visible-Rows-to-Variant-Array-Without-Looping
Private Function Get_Filtered_Rows(source As Range) As Variant
    
    Dim area As Range
    Dim i As Long
    Dim numRows As Long, numColumns As Long
    Dim r As Long, c As Long, destRow As Long
    Dim areasArray() As Variant
    Dim outputArray() As Variant
    
    'Create an array of 2D arrays.  Each 2D array contains the values from the filtered areas
    
    ReDim areasArray(1 To source.Areas.Count)
    For i = 1 To source.Areas.Count
        Set area = source.Areas(i)
        areasArray(i) = area.Value
        numRows = numRows + area.Rows.Count
    Next
    numColumns = area.Columns.Count
    
    'Copy values from each 2D area to a 2D output array
    
    ReDim outputArray(1 To numRows, 1 To numColumns) As Variant
    destRow = 0
    For i = 1 To UBound(areasArray, 1)
        For r = 1 To UBound(areasArray(i), 1)
            destRow = destRow + 1
            For c = 1 To numColumns
                outputArray(destRow, c) = areasArray(i)(r, c)
            Next
        Next
    Next
    
    Get_Filtered_Rows = outputArray
    
End Function

The new Worksheet_Change event handler inserts new rows when you enter "Yes" in one cell or multiple contiguous cells at the same time in column K and the column A cell is "H".

 

[gaganji143]

Thanks, John for your help.