lionheart

Select your range C2:C32 > Home tab > Conditional Formatting > New Rule > Put the following formula =ISODD(CEILING(ROW()-1,5)/5) Click Forma button > Fill tab > Select a color of your choice Do the same steps but with the following formula and a different color =ISEVEN(CEILING(ROW()-1,5)/5)

Thanks a lot Mr. Mohamed for sharing As for the amount 4000 for example: In your file the tax amount = 40 and I don't think this correct The first 2800 has no tax so the tax amount should be 4000 - 2800 which is 1200 and the percent would be in that case 12 and not 40

=SUMPRODUCT((D3>{2800,4000,5000,6000})*(D3-{2800,4000,5000,6000}),({0.01,0.015,0.025,0.03}-{0,0.01,0.015,0.025}))

In cell S5, put the formula and drag down and left =COUNTIFS($C$5:$C$400,$R5,F$5:F$400,"<>" & "")

Sub Test() Dim c As Range, s As String For Each c In [F4,H4,I4] If IsEmpty(c) Then s = s & IIf(s > "", ", ", "") & c.Address(False, False) Next c If s > "" Then MsgBox "You Must Fill " & s, 48, "Officena": Exit Sub For Each c In Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row) If c.Value = [F4] And c.Offset(, 2).Value2 > [I4].Value2 Then [J4].Value2 = c.Offset(, 2).Value2: Exit For End If Next c End Sub

Sub Test() Dim cn As Object, rs As Object, i As Long With Worksheets("Data") Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open ConnectionString:="Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;""" rs.Open "Transform First(Grade) Select ID, Gender, College, GPA, GPA2 From `" & .Name & "$A1:G` Where ID Is Not Null Group By ID, Gender, College, GPA, GPA2 Pivot Subject;", cn, 3 With Worksheets("Report").Range("A1") .CurrentRegion.ClearContents .Range("A2").CopyFromRecordset rs For i = 0 To rs.Fields.Count - 1 .Cells(1, i + 1) = rs.Fields(i).Name Next i End With End With Set cn = Nothing: Set rs = Nothing End Sub

Sub Test() Dim x, temp, myDir As String, fn As String, wsName As String myDir = ThisWorkbook.Path & "\" fn = "B.xlsx" wsName = ActiveSheet.Name If Dir(myDir & fn) = "" Then MsgBox "Workbook Not Found", vbExclamation: Exit Sub On Error Resume Next x = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & wsName & "'!R1C1") temp = Err.Number On Error GoTo 0 If (temp = 0) * (Not IsError(x)) Then With ActiveSheet.Range("A1:A8") .Formula = "='" & myDir & "[" & fn & "]" & wsName & "'!F4" .Value = .Value End With Else MsgBox "Worksheet Not Found", vbExclamation End If End Sub

Did you try the code with different days and returned the results as expected for you

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