Macro that Auto Fills Down Based when text Entered on Matching Columns

[squeakums]

Here are the example details of what I need; all is on the same tab:

When someone types something in column E; I'd like this macro to activate and fill down that same answer if it matches the person number and application name. I will pay for this answer if I can. It's because these files are large and have over 200,000+ rows.

Thank you!

 

[squeakums]

Okay there's the code I have based on what you said to change:

I'm getting an error on the one I have in red below. It is because I am trying to only run off 1 column (person #) and that rows.count 8 is throwing it off? Not sure what that rows count is. I feel like I am so close .. ah. Let me know if you want me to pay you for this and thanks!

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, b As Variant
    Dim i As Long
    Dim txt As String
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("An:An")) Is Nothing Then Exit Sub
    If (Target) <> "" Then
      [COLOR=rgb(209, 72, 65)]  [B]Range("H11:H" & Cells(Rows.Count, 8).End(xlUp).Row).Resize(, 33)[/B][/COLOR]
        ReDim b(1 To UBound(a))
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(a)
                txt = a(i, 1)
                If txt <> "" Then
                    If Not .exists(txt) Then
                        .Add txt, a(i, 33)
                        b(i) = a(i, 33)
                    Else
                        b(i) = .Item(txt)
                    End If
                End If
            Next
            Range("An11").Resize(UBound(a)) = Application.Transpose(b)
        End With
    End If
End Sub

 

[mohadin]

Of course

a = Range("a11:a" & Cells(Rows.Count, 8).End(xlUp).Row).Resize(, 40)

 

[squeakums]

I changed the code but still getting an error:

script out of range for txt = a(I)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, b As Variant
    Dim i As Long
    Dim txt As String
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("An:An")) Is Nothing Then Exit Sub
    If (Target) <> "" Then
         a = Range("a11:a" & Cells(Rows.Count, 8).End(xlUp).Row).Resize(, 33)
        ReDim b(1 To UBound(a))
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(a)
                txt = a(i)
                If txt <> "" Then
                    If Not .exists(txt) Then
                        .Add txt, a(i, 33)
                        b(i) = a(i, 33)
                    Else
                        b(i) = .Item(txt)
                    End If
                End If
            Next
            Range("An11").Resize(UBound(a)) = Application.Transpose(b)
        End With
    End If
End Sub

 

[squeakums]

Okay, so I am playing with the code, and this one almost works at the top; except around row 48,000 it gives an #n/a for someones ID, it is also not one of the ones I changed?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, b As Variant
    Dim i As Long
    Dim txt As String
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("An:An")) Is Nothing Then Exit Sub
    If (Target) <> "" Then
         a = Range("h11:h" & Cells(Rows.Count, 8).End(xlUp).Row).Resize(, 40)
        ReDim b(1 To UBound(a))
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(a)
                txt = a(i, 1)
                If txt <> "" Then
                    If Not .exists(txt) Then
                        .Add txt, a(i, 33)
                        b(i) = a(i, 33)
                    Else
                        b(i) = .Item(txt)
                    End If
                End If
            Next
            Range("An11").Resize(UBound(a)) = Application.Transpose(b)
        End With
    End If
End Sub

 

[mohadin]

Ahaa,
Well, I think this a limitation of Transpose Issue
I've some thing about this some where some time about overcome Transpose in excel
I'll Try to find it and will submitted to you.
So do not worry will be solved some how

 

[Fluff]

Try it like

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, b As Variant
    Dim i As Long
    Dim txt As String
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("An:An")) Is Nothing Then Exit Sub
    If (Target) <> "" Then
         a = Range("h11:h" & Cells(Rows.Count, 8).End(xlUp).Row).Resize(, 40)
        ReDim b(1 To UBound(a), 1 To 1)
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(a)
                txt = a(i, 1)
                If txt <> "" Then
                    If Not .Exists(txt) Then
                        .Add txt, a(i, 33)
                        b(i, 1) = a(i, 33)
                    Else
                        b(i, 1) = .Item(txt)
                    End If
                End If
            Next
            Range("An11").Resize(UBound(b)) = b
        End With
    End If
End Sub

 

[mohadin]

I was just thinking about it
But If you noticed

 ReDim b(1 To UBound(a), 1 To 1)

So Ubound(a)= Ubound(b) , Right?

 

[Fluff]

Yes they will be the same.

 

[mohadin]

Then

 Range("An11").Resize(UBound(b)) = b

will Repeat first value all the way
While

Range("An11").Resize(UBound(a)) = Application.Transpose(b)

Gives right resule for small amount of rows

 

[squeakums]

Try it like

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, b As Variant
    Dim i As Long
    Dim txt As String
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("An:An")) Is Nothing Then Exit Sub
    If (Target) <> "" Then
         a = Range("h11:h" & Cells(Rows.Count, 8).End(xlUp).Row).Resize(, 40)
        ReDim b(1 To UBound(a), 1 To 1)
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(a)
                txt = a(i, 1)
                If txt <> "" Then
                    If Not .Exists(txt) Then
                        .Add txt, a(i, 33)
                        b(i, 1) = a(i, 33)
                    Else
                        b(i, 1) = .Item(txt)
                    End If
                End If
            Next
            Range("An11").Resize(UBound(b)) = b
        End With
    End If
End Sub

Eureka!!! I think it's finally working! THANK YOU THANK YOU THANK YOU! Thank you!