lionheart

Glad you can solve it

Put the following line before the line of Next Next Should be If [E13] = 0 Then Exit For ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next

Private Sub CommandButton1_Click() ActiveCell.FormulaR1C1 = "10" TextBox1.Text = ActiveCell.FormulaR1C1 ExcelSpeak TextBox1.Text ActiveCell.Offset(1, 0).Select End Sub Function ExcelSpeak(sIn As String) As Boolean Application.Speech.Speak sIn, 0, 0, 0 ExcelSpeak = True End Function

Sub Test() Const nRows As Integer = 25, iRow As Integer = 15 Dim wb As Workbook, ws As Worksheet, sh As Worksheet, i As Integer Application.ScreenUpdating = False Set ws = ActiveSheet Set wb = Workbooks.Add(xlWBATWorksheet) For i = 1 To 10 ws.Range("A" & iRow).Value = (i - 1) * nRows + 1 If ws.Range("B" & iRow).Value = Empty Then Exit For ws.Copy After:=wb.Sheets(wb.Worksheets.Count) Set sh = ActiveSheet sh.Name = i With ws.Range("A" & iRow & ":BF39") .Copy sh.Range("A" & iRow).PasteSpecial xlPasteValues sh.Columns("BG:BH").Delete Application.Goto sh.Range("A1"), True End With Next i Application.DisplayAlerts = False With ActiveWorkbook .Worksheets(1).Delete .SaveAs ThisWorkbook.Path & "\Output", 51 .Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

No files attached

Thanks a lot my bro Hassona for your reply that explains the correct steps

Sub Test() Dim m As Long m = Range("A" & Rows.Count).End(xlUp).Row Range("A1:A" & m).Value = Evaluate("=LEFT(A1:A" & m & ",FIND(""."",A1:A" & m & "))&ROW(A1:A" & m & ")") End Sub

Private Sub CommandButton1_Click() ActiveCell.FormulaR1C1 = "10" TextBox1.Text = ActiveCell.FormulaR1C1 ActiveCell.Offset(1, 0).Select End Sub

Have you put the formula in the second sheet as I told you I think you didn't apply the steps correctly

Or simpler =VLOOKUP(B2,INDIRECT("'"&C2&"'!$A$4:$B$9"),2,0)

=VLOOKUP(B2,INDIRECT("'"&C2&"'!"&"$A$4:$B$9"),2,0)

I think this is a different request Your request from the beginning was how to affect on existing shapes

Give me specific example. I have tried the code and it works well on my side Have you put the formula in the second sheet as I told you

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim x, sh As Worksheet, r As Long, c As Long, n As Long, m As Long Set sh = Sheets(2) If Target.Address = "$L$8" Then Application.ScreenUpdating = False Application.EnableEvents = False Range("J11:T20").ClearContents r = 11: c = 10 For n = 2 To sh.Range("B" & Rows.Count).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 Application.EnableEvents = True Application.ScreenUpdating = True ElseIf Target.Column = 11 Or Target.Column = 13 Or Target.Column = 15 Or Target.Column = 17 Or Target.Column = 19 Then x = Application.Match(Range("L8").Value & Target.Offset(, -1).Value, sh.Columns(6), 0) If Not IsError(x) Then If Target.Value > sh.Cells(x, 5).Value Then MsgBox "Amount Is Less Than The Available Amount In Stock" & vbCrLf & "The Amount In Stock = " & sh.Cells(x, 5).Value, vbExclamation Application.EnableEvents = False Target.ClearContents Application.EnableEvents = True End If If Target.Value = sh.Cells(x, 5).Value Then MsgBox "Pay Attention! You Entered All The Amount In The Stock", vbInformation End If End If m = Range("B" & Rows.Count).End(xlUp).Row + 1 x = Application.Match(Target.Offset(, -1), Columns(2), 0) If Not IsError(x) Then Cells(x, 6) = Cells(x, 6) + Val(Target.Value) Else Cells(m, 2) = Target.Offset(, -1) Cells(m, 6) = Target.Value End If End If End Sub Before copy and paste the code, put the following formula in the second sheet in F2 and drag down =B2&C2 The hide column F in the second sheet as this is a helper column

You have to delete the shapes in your file and insert Oval shapes as I shown you Then press Alt+ F11 to login VBE editor and from Insert menu select Module then copy and paste the code I posted Back to the worksheet and press Alt + F8 and select the macro name and finally click Run

Working on my side without any problems

Insert standard module and put the following code. Draw a shape or button and assign macro to it Sub Test() Application.Run "Sheet1.Worksheet_Change", Sheet1.Range("C2") End Sub Or Sub Test() Dim lr As Long With Sheets(Range("C2").Value) lr = .Cells(Rows.Count, 1).End(xlUp).Row - 5 Sheet1.Cells(6, 1).Resize(lr, 6).Value = .Cells(6, 1).Resize(lr, 6).Value Sheet1.Range("C3") = .Range("C3") End With End Sub

Use the oval shapes from Insert tab > Illustrations > Shapes > Oval. Then use this code Don't forget to change the range to suit your range Sub Test() Dim x, c As Range, r As Long, y As Long, g As Long, b As Long Application.ScreenUpdating = False r = RGB(255, 0, 0): y = RGB(255, 255, 0) g = RGB(0, 176, 80): b = RGB(0, 112, 192) For Each c In Range("C8:F11") Set x = FindImage(c) If Not x Is Nothing Then If c.Value = 1 Then c.Font.Color = r: x.Fill.ForeColor.RGB = r ElseIf c.Value = 2 Then c.Font.Color = y: x.Fill.ForeColor.RGB = y ElseIf c.Value = 3 Then c.Font.Color = g: x.Fill.ForeColor.RGB = g ElseIf c.Value = 4 Then c.Font.Color = b: x.Fill.ForeColor.RGB = b End If End If Set x = Nothing Next c Application.ScreenUpdating = True End Sub Function FindImage(CellToCheck As Range) As Shape Dim wShape As Shape, addr addr = CellToCheck.Address For Each wShape In CellToCheck.Parent.Shapes If wShape.TopLeftCell.Address = addr Then Set FindImage = wShape: Exit Function Next wShape End Function

You can clear the coulmns D and column E and use the code to get the desired results Sub Test() Const t As Double = 50 With Range("E5") .Formula = "=C5*D5" .Offset(1).Resize(6).Formula = "=C6*D6+E5" End With With Range("D5") .Formula = "=RANDBETWEEN(1,INT(($A$1-SUM(C6:$C$11))/C5))" .Offset(1).Resize(4).Formula = "=RANDBETWEEN(1,INT(($A$1-SUM(C7:$C$11)-E5)/C6))" .Offset(5).Formula = "=RANDBETWEEN(IF($A$1-E9>" & t & "+(C10+C11),INT(($A$1-SUM(C11:$C$11)-E9-(" & t & "-C10))/C10),1),INT(($A$1-SUM(C11:$C$11)-E9)/C10))" .Offset(6).Formula = "=(A1-E10)/C11" End With With Range("D5:E11") .Value = .Value End With End Sub

Here's another file by formulas only. Select any empty cell and press DELETE button from the keyboard to get different results File.xlsx

Copy the code from my post. Go to excel worksheet and press Alt + F11 to login VBE editor then from Insert menu select Module and paste the code Now back to the worksheet and press Alt + F8 and select the macro called Test. That's all

Here's a nother file (Although there is no clear logic) Note that the code sometimes may take some time File.xlsm

That's weird Two other people liked the anwser while the OP didn't press the LIKE button Thanks a lot for Mohamed Ali And Hassona for the LIKE

Here's a file File.xlsx

=IF(B3="غ","ضعيف",IF(B3>=42,"ممتاز",IF(B3>=36,"جيد جدا",IF(B3>=25,"جيد","ضعيف"))))