lionheart

Sub Test() Dim a, x, d, zod As String, r As Integer, q As Integer, m As Integer, p As Integer zod = ZodiacSign(Date) Rem d = Day(ToHijri(Date)) d = Application.InputBox(prompt:="Enter The Day", Type:=1) If d = False Or d < 0 Then MsgBox "Invalid Entry", vbExclamation: Exit Sub r = (d * 2) + 5 a = Array("Aries", "Taurus", "Gemini", "Cancer", "Leo", "Virgo", "Libra", "Scorpio", "Sagittarius", "Capricorn", "Aquarius", "Pisces") x = Application.Match(zod, a, 0) q = Int(r / 5) m = r Mod 5 p = (x + q + IIf(m > 0, 1, 0)) - 2 MsgBox "Moon In '" & a(p Mod (UBound(a) + 1)) & "' Zodiac At Degree [" & m * 6 & "]", vbInformation End Sub Function ZodiacSign(myDate As Date) As String Dim yr As Integer yr = Year(myDate) Select Case myDate Case Is >= CDate("12/22/" & yr), Is <= CDate("1/19/" & yr) ZodiacSign = "Capricorn" Case Is <= CDate("2/18/" & yr) ZodiacSign = "Aquarius" Case Is <= CDate("3/20/" & yr) ZodiacSign = "Pisces" Case Is <= CDate("4/19/" & yr) ZodiacSign = "Aries" Case Is <= CDate("5/20/" & yr) ZodiacSign = "Taurus" Case Is <= CDate("6/20/" & yr) ZodiacSign = "Gemini" Case Is <= CDate("7/22/" & yr) ZodiacSign = "Cancer" Case Is <= CDate("8/22/" & yr) ZodiacSign = "Leo" Case Is <= CDate("9/22/" & yr) ZodiacSign = "Virgo" Case Is <= CDate("10/23/" & yr) ZodiacSign = "Libra" Case Is <= CDate("11/21/" & yr) ZodiacSign = "Scorpio" Case Is <= CDate("12/21/" & yr) ZodiacSign = "Sagittarius" End Select End Function Function ToHijri(dtGegDate As Date) As String VBA.Calendar = vbCalHijri ToHijri = dtGegDate VBA.Calendar = vbCalGreg End Function

Press Alt + F11 then from VBE menu select Insert then Module then paste the code posted And to use the function, suppose you have a date in cell A1, put the following formula in B1 =ZodiacSign(A1)

Here's a code but too long. First delete all the cells on the second worksheet then run the macro Sub Test() Const sRow As Integer = 6 Dim a, ws As Worksheet, sh As Worksheet, v As Long, i As Long, ii As Long, k As Long, c As Long, x As Long, cr As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) With sh.Cells .Clear: .UnMerge End With a = ws.Range("G4:H15").Value v = ws.Range("M18").Value ReDim b(1 To ws.Range("H16").Value, 1 To v + 2) For i = LBound(a) To UBound(a) For ii = 1 To a(i, 2) k = k + 1 b(k, 1) = a(i, 1) b(k, UBound(b, 2)) = ws.Cells(21 + ii, i + 1).Value Next ii Next i sh.Cells(sRow + 1, v + 2).Value = "Names" With sh.Range("A" & sRow + 1) .Value = "Subjects" .Offset(1).Resize(k, UBound(b, 2)).Value = b End With a = ws.Range("L4:M17").Value ReDim b(1 To 1, 1 To v): k = 0 For i = LBound(a) To UBound(a) For ii = 1 To a(i, 2) k = k + 1 b(1, k) = a(i, 1) & IIf(a(i, 2) > 1, Space(1) & CStr(ii), Empty) Next ii Next i sh.Range("B" & sRow + 1).Resize(, k).Value = b a = ws.Range("N4:N17").Value c = 2 For i = LBound(a) To UBound(a) If Not IsEmpty(a(i, 1)) Then x = x + 1 Select Case x: Case 1: cr = RGB(255, 255, 0) Case 2: cr = RGB(248, 203, 173) Case 3: cr = RGB(169, 208, 142) End Select With sh.Cells(sRow, c) .Value = x .Resize(, a(i, 1)).Merge .Resize(, a(i, 1)).Interior.Color = cr .Offset(1).Resize(, a(i, 1)).Interior.Color = cr End With c = c + a(i, 1) End If Next i With sh .Cells.ReadingOrder = xlRTL .Cells.HorizontalAlignment = xlCenter .Cells.VerticalAlignment = xlCenter With .Range("A" & sRow).CurrentRegion .Font.Name = "Times New Roman" .Font.Size = 14: .Font.Bold = True .Borders.Value = 1 .Rows.RowHeight = 18 .Columns.ColumnWidth = 8.43 .Columns(1).ColumnWidth = 14.5 With .Columns(.Columns.Count) .ColumnWidth = 14.5 .Interior.Color = RGB(255, 192, 0) .Cells(1).Interior.Color = xlNone End With End With End With Application.ScreenUpdating = True End Sub

Can you give us the exact dates for each zodiac sign as you did for Virgo (which is from 23 Aug to 22 Sept) https://en.wikipedia.org/wiki/Astrological_sign And is that Vrigo starts at 23 Aug and included and ends at 22 Sept and included. I mean if we need to compare a date then we say greater than or equal 23 Aug and less than or equal to 22 Sept Can you review this udf that returns the zodiac for each date Function ZodiacSign(myDate As Date) As String Dim yr As Integer yr = Year(myDate) Select Case myDate Case Is >= CDate("12/22/" & yr), Is <= CDate("1/19/" & yr) ZodiacSign = "Capricorn" Case Is <= CDate("2/18/" & yr) ZodiacSign = "Aquarius" Case Is <= CDate("3/20/" & yr) ZodiacSign = "Pisces" Case Is <= CDate("4/19/" & yr) ZodiacSign = "Aries" Case Is <= CDate("5/20/" & yr) ZodiacSign = "Taurus" Case Is <= CDate("6/21/" & yr) ZodiacSign = "Gemini" Case Is <= CDate("7/22/" & yr) ZodiacSign = "Cancer" Case Is <= CDate("8/22/" & yr) ZodiacSign = "Leo" Case Is <= CDate("9/22/" & yr) ZodiacSign = "Virgo" Case Is <= CDate("10/22/" & yr) ZodiacSign = "Libra" Case Is <= CDate("11/22/" & yr) ZodiacSign = "Scorpio" Case Is <= CDate("12/21/" & yr) ZodiacSign = "Sagittarius" End Select End Function

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, dic As Object, s As String, t As String, i As Long, c As Long Set ws = ThisWorkbook.Worksheets(1): Set sh = ThisWorkbook.Worksheets(2) Set dic = CreateObject("Scripting.Dictionary") a = ws.Range("A3").CurrentRegion.Value For i = LBound(a) + 1 To UBound(a) s = a(i, 2) & Chr(2) & a(i, 3) If Not dic.Exists(a(i, 1)) Then dic.Add s, a(i, 4) Next i For i = 2 To sh.Cells(Rows.Count, "B").End(xlUp).Row For c = 3 To 8 t = sh.Cells(i, 2).Value & Chr(2) & sh.Cells(3, c).Value If dic.Exists(t) Then sh.Cells(i, c).Value = dic(t) Next c Next i End Sub

This is exactly what the code did. Generally, we can wait for other members to share their ideas God bless you

. You have to explain in words the exact problem, use Arabic (I can get the Arabic well) I will let other members share in the thread as I am confused and can't get what is the problem exactly

If you removed the line I referred to, the code will not update or even touch the column K in the first sheet To put comment, you can use apostrophe (') at the beginning of the line or using the word rem

Look you have to study the code well so as to be able to modify and to learn something new (at least the basics) If I got what you meant, just comment this line out Sheets(1).Cells(x, 11).Value = Sheets(1).Cells(x, 5).Value

What do you mean by the second one Can you use images to explain your problem as I am confused about the problem

Dim tmp 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) Then If MsgBox("New Stock Will Be Updated . If OK Click 'Yes'", vbYesNo + vbQuestion) = vbYes Then Sheets(1).Cells(x, 11).Value = Sheets(1).Cells(x, 5).Value Sheets(1).Cells(x, 5).Value = Target.Offset(, 2).Value Cells(Target.Row, 1).Value = Format(Date & Space(1) & Time, "dd/mm/yyyy hh:mm") Else If Not IsEmpty(tmp) Then Target.Value = tmp End If End If Application.EnableEvents = True End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 2 And Target.Column = 7 Then tmp = Target.Value End Sub

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