CODEWITHSUNDEEP
excelvba
S_B
S_B

Reputation: 11

Look for a cell value (more than one instance) in a column then copy corresponding row values to another row (against other cell value)

I want to look for value of Forecast in cell (F column) (more than one instance - unique key is Prod and Cust), then copy corresponding row values to other rows identified by Edited Forecast value in another cell (more than one instance - unique key is Prod and Cust (same column).)

enter image description here

This is only copying Row values.

Private AutomationObject As Object

Sub Save ()
    Dim Worksheet as Worksheet

    Set Worksheet = ActiveWorkbook.Worksheets("Sheet")
    Worksheet.Range("M18:AX18").Value = Worksheet.Range("M15:AX15").Value
End Sub

Upvotes: 1

Views: 85

Answers (1)

VBasic2008
VBasic2008

Reputation: 54767

Fill Blanks (Unique Dictionary)

Option Explicit

Sub FillBlanks()
    
    Const sFirstCellAddress As String = "D3"
    Const sDelimiter As String = "@"
    Const dCols As String = "I:K"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim srg As Range
    Dim rCount As Long
    With ws.Range(sFirstCellAddress)
        Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        rCount = lCell.Row - .Row + 1
        Set srg = .Resize(rCount, 2)
    End With
    Dim sData As Variant: sData = srg.Value
    
    Dim drg As Range: Set drg = srg.EntireRow.Columns(dCols)
    Dim dcCount As Long: dcCount = drg.Columns.Count
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim rg As Range
    Dim r As Long
    Dim sString As String
    
    For r = 1 To rCount
        sString = sData(r, 1) & sDelimiter & sData(r, 2)
        If Application.CountBlank(drg.Rows(r)) = dcCount Then
            If dict.Exists(sString) Then
                If IsArray(dict(sString)) Then
                    drg.Rows(r).Value = dict(sString)
                Else
                    dict(sString).Add drg.Rows(r)
                End If
            Else
                Set dict(sString) = New Collection
                dict(sString).Add drg.Rows(r)
            End If
        Else
            If dict.Exists(sString) Then
                If IsArray(dict(sString)) Then
                    'drg.Rows(r).Value = dict(sString) ' overwrite!?
                Else
                    For Each rg In dict(sString)
                        rg.Value = drg.Rows(r).Value
                    Next rg
                    dict(sString) = drg.Rows(r).Value
                End If
            Else
                dict(sString) = drg.Rows(r).Value
            End If
        End If
    Next r
    
    MsgBox "Data updated.", vbInformation
    
End Sub

Upvotes: 1

Related Questions