Excel VBA Trigger

[aqeelnokia99]

Dear Expert ,
i want 1 VBA if i write word "done" in any row in column f it need to check 2 Row above in column G we have 2 rows with name "Box" and "Bag" in G if any of these not found add 1 or 2 row according to missing Text above in case not found with Value G=Box or Bag H = "Card" For example i write done in F11 its need to check 2 row back Like G10 and G9 we have any missing value Like "Box" Or "Bag" in case Box not found add 1 row with Box in G10 and H10 value will Be "Card" also auto fill value of column B 1 row above value Like for example if we add 1 row G10 fill value of B10 =B9 if we add 2 rows like "Box" Or "Bag" both not found so value in B9 and B10 both will be B8

 

[aqeelnokia99]

Thanks its working 1 last Condition need auto fill value from above in column B and C in case if we added now Line if Like for Example if Cardboard box was not found in 2 row above we add it now new added row must take data from his 1 row above Like if we add row row 10 B10 Value =B9 C10 Value =C9

I also find 1 issue after type done 2 or 3 time its auto fill all row with name done

 

[RudRud]

I also find 1 issue after type done 2 or 3 time its auto fill all row with name doneView attachment 94359

Hi @aqeelnokia99 , can you show some example with expected result via XL2BB? Thanks

 

[aqeelnokia99]

In Excel when you have some thing Copied in your Clip board and you insert 1 row its auto Fill all Clip board data in all that row this is i think happening now also if we remove some rows like 1000 its stuck Excel

 

[aqeelnokia99]

Kindly make Range of This VBA F2:F5000 then it will work Fast

 

[RudRud]

Something like this?

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Columns(6)) Is Nothing Then
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare

Application.EnableEvents = False

For Each c In Target
If c.Value = "done" Then

For i = 1 To 2
'If Not Len(Cells(c.Row - i, "g").Value) > 3 Then
'do nothing
'Else
dict.Add Cells(c.Row - i, "g").Value, i
'End If
Next i

If Not dict.Exists("Cardboard box") Then
    c.EntireRow.Insert
    Cells(c.Row - 1, "g").Value = "Cardboard box"
    Cells(c.Row - 1, "I").Value = "Cardboard"
    Cells(c.Row - 1, "J").Value = "Cardboard and paper"
    Cells(c.Row - 1, "K").Value = "packaging"
    Cells(c.Row - 1, "M").Value = "Kina"
    Cells(c.Row - 1, "N").Value = 1500
    Cells(c.Row - 1, "O").Value = 1
    Cells(c.Row - 1, "F").Value = "[comp.]"
     Cells(c.Row - 1, "B").Resize(1, 2).Value = Cells(c.Row - 1, "B").End(xlUp).Resize(1, 2).Value
End If

If Not dict.Exists("PE bag") Then
    c.EntireRow.Insert
    Cells(c.Row - 1, "g").Value = "PE bag"
    Cells(c.Row - 1, "I").Value = "HDPE"
    Cells(c.Row - 1, "J").Value = "plastic"
    Cells(c.Row - 1, "K").Value = "packaging"
    Cells(c.Row - 1, "M").Value = "Kina"
    Cells(c.Row - 1, "N").Value = 100
    Cells(c.Row - 1, "O").Value = 1
    Cells(c.Row - 1, "F").Value = "[comp.]"
   
End If


ElseIf c.Value = "not done" Then

End If
Next

End If

Application.EnableEvents = True

End Sub

 

[aqeelnokia99]

we still have same issue also Kindly make range 5000 so its will be super fast

 

[aqeelnokia99]

if you can share your email then i can send you Excel file

 

[RudRud]

if you can share your email then i can send you Excel file

you can upload into dropbox/google drive anyway,

Cells(c.Row - 1, "B").Resize(5000, 2).Value = Cells(c.Row - 1, "B").End(xlUp).Resize(1, 2).Value

(first resize row you can change to 5000 if you wish to fill up 5000 rows)

Please elaborate more with expected result or share the file, otherwise its hard to execute it

 

[aqeelnokia99]

Please check sheet

TEST (2).xlsm

drive.google.com

 

[aqeelnokia99]

Kindly make all Range till 5000 Trigger as well also fix Yellow Highlighted issue