lionheart

If you don't want to delete the row, just comment the line Target.EntireRow.Delete

Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 2 And Target.Column = 7 Then Application.EnableEvents = False x = Application.Match(Target.Offset(, -5).Value, Sheets(1).Columns(3), 0) If Not IsError(x) And Target.Offset(, -1).Value = "sale" Then If MsgBox("New Stock Will Be Updated And This Row Will Be Delete. If OK Click 'Yes'", vbYesNo + vbQuestion) = vbYes Then Sheets(1).Cells(x, 5).Value = Sheets(1).Cells(x, 5).Value - Target.Value Target.EntireRow.Delete End If End If Application.EnableEvents = True End If End Sub Change the quantity in column G to trigger the code

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, r As Range, txt As String, i As Long Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) sh.Range("A3:C" & Rows.Count).ClearContents Set r = ws.Range("F2:M" & ws.Cells(Rows.Count, "F").End(xlUp).Row) a = r.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 8) = sh.Range("A1").Value Then txt = Join(Array(a(i, 2), a(i, 3)), Chr(2)) If Not .Exists(txt) Then .Item(txt) = .Count + 1 a(.Count, 1) = a(i, 2) a(.Count, 2) = a(i, 3) a(.Count, 3) = Evaluate("SUMIFS('" & ws.Name & "'!" & r.Columns(4).Address & ",'" & ws.Name & "'!" & r.Columns(1).Address & ","">=""&" & "'" & sh.Name & "'!" & Range("C1").Address & ", '" & ws.Name & "'!" & r.Columns(1).Address & ",""<="" &" & "'" & sh.Name & "'!" & Range("D1").Address & ",'" & ws.Name & "'!" & r.Columns(2).Address & "," & Chr(34) & a(.Count, 1) & Chr(34) & ",'" & ws.Name & "'!" & r.Columns(3).Address & "," & Chr(34) & a(.Count, 2) & Chr(34) & ")") End If End If Next i i = .Count End With sh.Range("A3").Resize(i, 3).Value = a End Sub

The total number 300000 is not clear, how do you calculate that manually

Sub Test() Dim r As Range, c As Range, cel As Range, x As Long Application.ScreenUpdating = False Application.EnableEvents = False Set r = Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row) Set c = Range("H5") Set cel = Range("L1") cel.CurrentRegion.ClearContents Do With cel .Offset(1).Resize(r.Rows.Count).Formula = "=SumSolver(" & r.Address & ", " & c.Address & ", " & x + 1 & ", Row(A1))" If .Offset(1).Value = "" Then Exit Do x = x + 1 .Value = x Set cel = cel.Offset(, 1) End With Loop Until x = 100 Application.EnableEvents = True Application.ScreenUpdating = True End Sub Function SumSolver(numbers, t As Double, Optional pt As Long = 1, Optional s As Long = 1) Dim i&, ii!, p&, n(), w, r# If pt < 1 Or s < 1 Then SumSolver = CVErr(xlErrNum): Exit Function w = Split(Application.Trim(Replace(Replace("|" & Join(Application.Transpose(numbers), "||") & "|", "|0|", "|"), "|", " ")), " ") ReDim n(1 To UBound(w) + 1) For ii = 1 To 2 ^ (UBound(w) + 1) - 1 For i = 1 To UBound(w) + 1 n(i) = (Int(ii / 2 ^ (i - 1)) Mod 2) * w(i - 1) r = r + n(i) Next i If Val(r) = Val(t) Then p = p + 1: If pt = p Then Exit For r = 0 Next ii w = Split(Application.Trim(Replace(Replace("|" & Join(n, "||") & "|", "|0|", "|"), "|", " ")), " ") If pt > p Or s > UBound(w) + 1 Then SumSolver = "" Else SumSolver = Val(w(s - 1)) End Function The UDF SumSolver taken from this link http://excel-egy.com/forum/t2787

Right-click on the worksheet named Transactions and click on View Code to paste the code in the worksheet module and as for the second point not clear for me at all

Sheet1 should be unprotected to let the code modify the quantity In the following code replace this word ÈíÚ with the Arabic equivalent This is worksheet module (Transaction worksheet) Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 2 And Target.Column = 7 Then Application.EnableEvents = False x = Application.Match(Target.Offset(, -5).Value, Sheets(1).Columns(3), 0) If Not IsError(x) And Target.Offset(, -1).Value = "ÈíÚ" Then If MsgBox("New Stock Will Be Updated And This Row Will Be Delete. If OK Click 'Yes'", vbYesNo + vbQuestion) = vbYes Then Sheets(1).Cells(x, 5).Value = Sheets(1).Cells(x, 5).Value - Target.Value Target.EntireRow.Delete End If End If Application.EnableEvents = True End If End Sub

Many thanks for all of you

Mr. Mohamed's solution is simpler and better but this is my try using VBA in worksheet module Private Sub Worksheet_Change(ByVal Target As Range) Dim x, r If Target.CountLarge > 1 Then Exit Sub Application.EnableEvents = False With Sheets(2) If Target.Address = "$E$5" Then If IsEmpty(Target) Then Target.Offset(, 1).ClearContents x = Application.Match(Target.Offset(, -1), .Rows(1), 0) r = Application.Match(Target.Value, .Columns(x), 0) If Not IsError(x) And Not IsError(r) Then Target.Offset(, 1).Value = .Cells(r, x).Offset(, 1).Value End If End With Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim x, c As Long, sList As String If Target.CountLarge > 1 Then Exit Sub Application.EnableEvents = False With Sheets(2) If Target.Address = "$D$5" Then For c = 1 To 53 Step 2 sList = sList & IIf(sList = Empty, Empty, ",") & .Cells(1, c).Value Next c With Target.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="" & sList End With Target.Offset(, 1).Resize(1, 2).ClearContents ElseIf Target.Address = "$E$5" Then If IsEmpty(Target.Offset(, -1)) Then Target = Empty Else If Target = Empty Then x = Application.Match(Target.Offset(, -1), .Rows(1), 0) If Not IsError(x) Then Target.Validation.Delete Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & .Name & "!" & .Range(.Cells(2, x), .Cells(.Cells(Rows.Count, x).End(xlUp).Row, x)).Address End If End If End If End If End With Application.EnableEvents = True End Sub

Thank you everybody. It is my honor to be one of the forum members

Private Sub Worksheet_Change(ByVal Target As Range) Dim x, n As Long, r As Long, c As Long, m As Long Dim sh As Worksheet: Set sh = Sheets("رصيد") Application.EnableEvents = False If Target.Address = "$L$8" Then Range("J11:L20").ClearContents c = 10: r = 11 For n = 2 To sh.Cells(Rows.Count, 1).End(3).Row If sh.Range("b" & n) = Target Then Cells(r, c) = sh.Range("c" & n) r = IIf(c = 18, r + 1, r): c = IIf(c = 18, 10, c + 2) End If Next n ElseIf Target.Count = 1 And Target.Row >= 11 And Target.Row <= 22 And (Target.Column = 11 Or Target.Column = 13 Or Target.Column = 15 Or Target.Column = 17 Or Target.Column = 19) And IsNumeric(Target.Value) Then m = Cells(Rows.Count, 2).End(xlUp).Row + 1 x = Application.Match(Target.Offset(, -1).Value, Columns(2), 0) If Not IsError(x) Then Cells(x, 6).Value = Cells(x, 6).Value + Val(Target.Value) Else Cells(m, 2).Value = Target.Offset(, -1).Value Cells(m, 6).Value = Target.Value End If End If Application.EnableEvents = True End Sub

Thank you very much for your kind attitude

Try removing the word PtrSafe and replace LongPtr with Long

Sub Test() Const colResult As Integer = 4 Dim a, x, ws As Worksheet, dic As Object, m As Long, i As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) With ws Set dic = CreateObject("Scripting.Dictionary") m = .Cells(Rows.Count, 1).End(xlUp).Row With .Columns(colResult) .ClearContents .Cells(1).Value = "Results" End With a = WorksheetFunction.Transpose(.Range("A1:B" & m).Value) For i = LBound(a, 2) To UBound(a, 2) If Not dic.Exists(a(1, i)) Then dic.Add a(1, i), a(2, i) Else dic.Item(a(1, i)) = dic.Item(a(1, i)) & ";" & a(2, i) End If Next i .Range("J1").Resize(UBound(dic.Keys) + 1) = Application.Transpose(dic.Keys) .Range("K1").Resize(UBound(dic.Items) + 1) = Application.Transpose(dic.Items) Set dic = Nothing With .Range("E2:E" & m) .Formula = "=COUNTIF($A$1:A2,A2)" End With For i = 2 To m x = Application.Match(.Cells(i, 1), .Columns(10), 0) If .Cells(i, 5) = 1 And Not IsError(x) Then If InStr(.Cells(x, 11), ";") Then .Cells(i, 4).Value = Mid(.Cells(x, 11).Value, InStr(.Cells(x, 11), ";") + 1) End If End If Next i .Columns(5).ClearContents .Columns("J:K").ClearContents End With Application.ScreenUpdating = True End Sub

Sub Test() Dim ws As Worksheet, c As Range, myDir As String, fn As String, shName As String, s As String, t As String, m As Long, n As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) myDir = ThisWorkbook.Path & "\" With ws.Range("B4:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row) .Offset(, 1).Resize(.Rows.Count, 4).ClearContents For Each c In .Cells fn = Dir(myDir & "\" & c.Value & ".xlsx") If fn = Empty Then GoTo NXT With GetObject(myDir & fn).Worksheets.Item(1) shName = .Name m = .Cells(Rows.Count, "B").End(xlUp).Row End With For n = 1 To 4 s = "'" & myDir & "[" & fn & "]" & shName & "'!" & Range("B6:B" & m).Address(True, True, -4150) t = Replace(s, Split(s, "!")(1), Range("C6:C" & m).Address(True, True, -4150)) c.Offset(, n).Value = Application.ExecuteExcel4Macro("SUMPRODUCT((" & s & "='" & ws.Name & "'!" & c.Offset(3 - c.Row, n).Address(True, True, -4150) & ")*(" & t & "))") Next n NXT: Next c End With Application.ScreenUpdating = True End Sub

To get the last row in specific column using formulas you can use these formulas =SUMPRODUCT((MAX(IFERROR(((A:A)<>""),TRUE)*ROW(A:A)))) =LOOKUP(2,1/(NOT(ISBLANK(A:A))),ROW(A:A)) To get the data in the last row in specific column, you can use this formula =LOOKUP(2,1/(B:B<>""),B:B) But if you seek to get the last row in any column in the active sheet, you have to use VBA instead Sub Test() Dim r As Range, m As Long Set r = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues) If Not r Is Nothing Then MsgBox "Last Row In The Active Worksheet: " & r.Row & vbCrLf & "The Last Row Is In Column: " & r.Column End If End Sub

Thank you very much Mr. Mohamed for your kind words and it is a great honor to be among you

Thank you very much for this trust. I am not expert, I am just a learner

Sub Test() Dim a, dic As Object, i As Long Set dic = CreateObject("Scripting.Dictionary") a = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value For i = LBound(a) To UBound(a) If dic.Exists(a(i, 1)) Then a(i, 1) = Empty Else dic.Add a(i, 1), 1 Next i Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a End Sub

It is better to use doubleclick event. Try the following code in the worksheet module Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim x, m As Long Cancel = True If Not Intersect(Target, Range("J11:L20")) Is Nothing Then Application.EnableEvents = False x = Application.Match(Target, Columns(2), 0) If Not IsError(x) Then Cells(x, 6) = Cells(x, 6) + 1 Else m = Range("B" & Rows.Count).End(xlUp).Row + 1 Cells(m, 2) = Target.Value Cells(m, 6) = Cells(m, 6) + 1 End If Application.EnableEvents = True End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lr As Long If Not Intersect(Target, Range("A11:H30")) Is Nothing Then Application.EnableEvents = False lr = Target.Row Range("B1").Value = lr With Shapes("Edit") .Left = Sheets(1).Range("i" & lr).Left - 32 .Top = Sheets(1).Range("i" & lr).Top .Visible = msoCTrue End With With Shapes("Delete") .Left = Sheets(1).Range("i" & lr).Left - 16 .Top = Sheets(1).Range("i" & lr).Top .Visible = msoCTrue End With Application.EnableEvents = True End If End Sub

Sub Test() With Sheet1 Sheet2.Range("C15").CurrentRegion.Offset(1).Clear .[J2].Formula = Replace("='#'!D3<>""""", "#", .Name) .[A2].CurrentRegion.AdvancedFilter 2, .[J1:J2], Sheet2.[C15:H15] .[J2].Clear End With End Sub

Thanks a lot Mr. Mohamed but I have found that UDF in an English forum and not here but I don't remember the link. Generally, thanks for your great efforts. I found the UDF on that link too http://excel-egy.com/forum/t2146

I think your office version doesn't support TextJoin function so you can use UDF that is alternative to TextJoin. You will use the same formula exactly but replace the name of TextJoin with MyTextJoin Function MyTextJoin(break As String, ignore As Boolean, txt) As String Dim t, s$, i% For Each t In txt s = s & IIf(i = 0 Or (ignore = True And (s = "" Or t = "")), "", break) & t i = 1 Next t MyTextJoin = s End Function

Can you attach your file to have a look at the problem? And what office version do you use

What about the VBA code? Is it working well or not