lionheart

Here's a version that merges cells although I see not practical and not useful later
Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, n As Long, i As Long, c As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5: n = m Application.ScreenUpdating = False Application.DisplayAlerts = False With sh.Rows("5:" & Rows.Count) .ClearContents: .Borders.Value = 0: .UnMerge: .RowHeight = 20.25 End With For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i For c = 1 To 3 With sh.Range(sh.Cells(n, c), sh.Cells(m - 1, c)) .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Next c If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 n = m End If Next r sh.Range("A5:F" & m - 1).Borders.Value = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub  

The error is because you have protected your worksheets so I think you encountered the error. To fix the problem just unprotect the worksheet before working on it and at the end to protect it again
Sub HideRowsBasedOnCondition() Dim conditionValue, ws As Worksheet, conditionCell As Range, rowRange As Range For Each ws In ThisWorkbook.Sheets Set conditionCell = ws.Range("V1") conditionValue = conditionCell.Value ws.Unprotect ws.Rows.Hidden = False If conditionValue = 28 Then Set rowRange = ws.Rows("1363:1387") rowRange.Hidden = True ElseIf conditionValue = 29 Then Set rowRange = ws.Rows("1361:1362") rowRange.Hidden = True End If ws.Protect Next ws End Sub I just added two lines
ws.Unprotect And
ws.Protect  

Try this code
Sub Test() Dim ws As Worksheet, r As Long, lr As Long, i As Long, j As Long, m As Long Application.ScreenUpdating = False Set ws = Sheet1 ReDim a(1 To 1000, 1 To 17) With ws lr = .Cells(Rows.Count, "B").End(xlUp).Row For r = 10 To lr If Application.WorksheetFunction.CountBlank(.Range("E" & r).Resize(, 11)) <> 11 Then i = i + 1 For j = 2 To 18 a(i, j - 1) = .Cells(r, j).Value Next j End If Next r If i > 0 Then m = .Cells(Rows.Count, "AM").End(xlUp).Row + 1 m = IIf(m = 5, 9, m) .Range("AM" & m).Resize(i, UBound(a, 2)).Value = a Application.Goto .Range("AM" & m), True End If End With Application.ScreenUpdating = True MsgBox "Done", 64 End Sub  

In cell D1 type the number 666 then in cell D4 put the formula
="Shatbeyya "&($D$1+5*(ROW()-4))&"-"&($D$1+4+5*(ROW()-4))  

Try this code
Private Sub UserForm_Initialize() With Me.TextBox1 .Text = "Hello World" .Enabled = False End With End Sub Private Sub TextBox2_Change() Dim s As String, i As Long s = Me.TextBox2.Value For i = 1 To Len(s) If InStr(1, Me.TextBox1.Value, Mid(s, i, 1)) > 0 Then MsgBox Mid(s, i, 1) & " Is Found In TextBox1" s = Replace(s, Mid(s, i, 1), vbNullString) Me.TextBox2.Value = s Exit For End If Next i End Sub  

Try
Sub Test() Dim lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F3"), Order:=xlAscending .SortFields.Add Key:=Range("G3"), Order:=xlDescending .SortFields.Add Key:=Range("H3"), Order:=xlAscending .SetRange ActiveSheet.Range("A3:H" & lr) .Header = xlYes .Apply End With End With End Sub  

In ThisWorkbook Module
Private Sub Workbook_Open() Application.OnKey "{F9}", "TestMacro" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F9}" End Sub  
In Standard Module
Sub TestMacro() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Qution") ws.Range("G17").Value = Empty: ws.Range("D17").Value = Empty With ws.Range("D17") .Formula = "=RANDBETWEEN(data1!A1,data1!A30)" .Value = .Value End With With Application .ScreenUpdating = True .EnableEvents = False .Calculation = xlCalculationManual .Wait Now + TimeValue("00:00:05") ws.Range("G17").Formula = "=LOOKUP(D17,data1!A1:A730,data1!F1:F30)" .Calculate .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub  

Try this code
Sub ToggleButton_ON_OFF() Const ONKEY As String = "On", OFFKEY As String = "Off" Dim ws As Worksheet, shOnOff As Shape, shToggle As Shape, shRadio As Shape, s As String Set ws = ActiveSheet With ws Set shOnOff = .Shapes("txtboxOnOff") Set shToggle = .Shapes("ToggleButton1") Set shRadio = .Shapes("radioButton") End With With shOnOff s = .TextFrame.Characters.Text .TextFrame.Characters.Text = IIf(s = ONKEY, OFFKEY, ONKEY) ws.Rows("12").Hidden = (s = OFFKEY) .TextFrame.HorizontalAlignment = IIf(s = ONKEY, xlHAlignLeft, xlHAlignRight) shToggle.Fill.ForeColor.RGB = IIf(s = ONKEY, RGB(232, 27, 34), RGB(117, 199, 1)) shRadio.Left = shToggle.Left + IIf(s = ONKEY, shToggle.Width - shRadio.Width - 5, 5) End With End Sub  

Use this code
Sub DropDownSelection() Dim v, x, ws As Worksheet, myDrop As DropDown Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("1") Set myDrop = ActiveSheet.DropDowns("myDropDown") v = myDrop.List(myDrop.Value) x = Application.Match(v, ws.Columns(3), 0) If Not IsError(x) Then With ActiveSheet .Range("C9").Value = ws.Cells(x, 3).Value .Range("J9").Value = ws.Cells(x, 4).Value 'complete by yourself End With End If Application.ScreenUpdating = True End Sub  
Assign macro to the drop down by right-click on the drop down and select Assign Macro and select the macro name [DropDownSelection]

I don't like attaching files
But I see there is a huge mess
 
Click Down arrow first then use Up arrow
File.xlsb

Steps to solve the problem using conditional formatting
First: Select Range A1:A7
 
Second: From Home Tab Select Conditional Formatting  & New Rule

 
Third: Select Rule [Use a formula to determine which cells to format] - Type Formule [=B1=0] - Click [Format]

 
Fourth: Select Tab >> Color DropDown >> Select [White, Backgrounds 1] >> Click [OK]

 
Finally Click OK To Close [New FOrmatting Rule] Window

Try this code
Sub DrawCircles() Const SROW As Long = 7, EROW As Long = 11, SCOL As Long = 2, ECOL As Long = 10 Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, rd As Double Application.ScreenUpdating = False Call RemoveCircles Set ws = ActiveSheet For i = SROW To EROW With ws n = .Range("K" & i).Value For j = ECOL To SCOL Step -1 If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then rd = 0.5 * Application.Min(.Cells(i, j).Height, .Cells(i, j).Width) sColName = Split(.Cells(1, j).Address, "$")(1) With ActiveSheet.Shapes.AddShape(msoShapeOval, Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * rd), .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * rd), 2 * rd, 2 * rd) .Line.Weight = 1.5 .Line.ForeColor.RGB = RGB(0, 0, 255) .Fill.Visible = msoFalse End With n = n - 1 End If If n = 0 Then Exit For Next j End With Next i Application.ScreenUpdating = True End Sub Private Sub RemoveCircles() Dim shp As shape For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp End Sub  
Const SROW As Long = 7, EROW As Long = 11, SCOL As Long = 2, ECOL As Long = 10 In this line you can specify the start row SROW & end row EROW & start column SCOL & end column ECOL

When protecting the worksheet, you have to follow these steps
Review Tab >> Click on Protect Sheet
Check the option Edit Objects
Enter your password if you desire and you can leave it empty

Here's the code and please try to learn from the solutions as it is a bad attitude to wait the help all the time from other people
Sub Test() Dim a, e, sh As Worksheet, f As Boolean, lr As Long, r As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("Saad") f = True: sh.Cells.ClearContents For Each e In Array("Sheet1", "Sheet2", "Sheet3") With ThisWorkbook.Worksheets(e) lr = .Cells(Rows.Count, "M").End(xlUp).Row a = .Range("K5:X" & lr).Value If f Then r = 5: f = False Else r = sh.Cells(Rows.Count, "C").End(xlUp).Row + 1 sh.Cells(r, "C").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With Next e Application.ScreenUpdating = True End Sub  

Here's a modified udf to be compatible with older versions of excel
Function DistributeNumber(ByVal num As Long, ByVal chunks As Long, ByVal iIndex As Long) Dim i As Long ReDim b(chunks - 1) For i = 0 To chunks - 1 If i = chunks - 1 Then b(i) = num Else b(i) = WorksheetFunction.RoundUp(num / (chunks - i), 0) num = num - b(i) End If Next i On Error Resume Next DistributeNumber = b(iIndex - 1) If Err.Number <> 0 Then DistributeNumber = vbNullString: Err.Clear On Error GoTo 0 End Function  
you can use the udf as formula (but you will have to drag the formula)
Say the number is K1 so the formula in cell K2 should be
=DistributeNumber(K$1,5,ROW(A1)) Drag the formula down to get the results

Try this
Option Explicit Sub Add_Circles() Dim ws As Worksheet, myRng As Range, c As Range, v As Shape, col As Long Application.ScreenUpdating = False Set ws = ActiveSheet Set myRng = ws.Range("F3:N13") myRng.RowHeight = 35: myRng.ColumnWidth = 10 Call Remove_Circles For Each c In myRng.Cells col = c.Column If c.Value < ws.Cells(2, col) Or c.Value = Chr(219) Then Set v = ws.Shapes.AddShape(msoShapeOval, c.Left + 15, c.Top + 2, 30, 30) With v With .Fill .Visible = msoTrue .ForeColor.RGB = RGB(166, 166, 166) End With With .TextFrame2 .TextRange.ParagraphFormat.Alignment = msoAlignCenter With .TextRange.Font .Fill.ForeColor.RGB = RGB(0, 0, 0) .Size = c.Font.Size .Bold = c.Font.Bold .Name = c.Font.Name End With .WordWrap = msoFalse End With With .TextFrame .Characters.Text = c.Value .MarginRight = 4 .MarginTop = 2 .MarginLeft = 4 .MarginBottom = 2 End With End With End If Next c Application.ScreenUpdating = True End Sub Sub Remove_Circles() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp End Sub  

The file is not perfect file as it has a lot of formulas that make the file slow. Generally follow the steps accurately to solve the problem of sort
 
First select the shape that has the caption GIRLS and rename the shape from the Name Box to shpGirls

 
Do the same step with the shape of BOYS and rename it to shpBoys
 
Insert new module and paste the code
Sub Sort_By_Boys_Girls() Dim shp As Shape, lr As Long, n As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set shp = ActiveSheet.Shapes(Application.Caller) If shp.Name = "shpGirls" Then n = 1 Else n = 2 With ActiveSheet lr = .Cells(Rows.Count, "D").End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F9"), Order:=xlAscending .SortFields.Add Key:=Range("I9"), Order:=n .SortFields.Add Key:=Range("D9"), Order:=xlAscending .SetRange ActiveSheet.Range("D9:AH" & lr) .Header = xlNo .Apply End With End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub  
 Finally assign the macro named [Sort_By_Boys_Girls] to both the shapes
 

The topic must be CLOSED as you did not respond properly to Mohamed Hicham in a good way
Generally, I will share my idea but I will not extend my reply if you have more questions
 
First create a userform with TextBox1 & ListBox1 controls
Second paste the following code on userform module
Option Explicit Private arrData, ws As Worksheet Private Sub UserForm_Initialize() Dim lr As Long Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row arrData = ws.Range("C3:C" & lr).Value Me.ListBox1.List = Application.Transpose(arrData) End Sub Private Sub TextBox1_Change() Dim txt As String, i As Long Me.ListBox1.Clear If Len(Me.TextBox1.Value) = 0 Then Me.ListBox1.List = Application.Transpose(arrData): Exit Sub txt = Me.TextBox1.Value For i = LBound(arrData) To UBound(arrData) If InStr(LCase(arrData(i, 1)), LCase(txt)) > 0 Then Me.ListBox1.AddItem arrData(i, 1) End If Next i End Sub Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim x x = Application.Match(ListBox1.Value, ws.Columns(3), 0) With ws.Range("H3").Resize(, 4) .ClearContents If Not IsError(x) Then .Value = ws.Range("B" & x).Resize(, 4).Value Unload Me End If End With End Sub  
Now right-click the worksheet name and select [View Code] and paste the following code
Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$H$3" Then Cancel = True UserForm1.Show End If End Sub  
The code usage
--------------------
Double click on cell H3 and the form will be shown then type some letters of the name you need to search and finally double click the name on the listbox to get the results in the range H3 to K3
Regards
 

Try this formula
=IF(C5="","",IF(AND(C5>$A$2,C5<=$B$2)=FALSE,"Not Calculated",IF(COUNTIF($A$5:$A5,A5)>3,"Not Rounded","Calculated")))  

Try
Sub Test() Dim ws As Worksheet, sh As Worksheet, tbl As ListObject, lr As Long, i As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets("Items"): Set sh = .Worksheets("Orders") End With Set tbl = sh.ListObjects(1) lr = tbl.Range.Rows.Count + tbl.Range.Row - 1 Do While sh.Cells(lr, "C").Value = Empty lr = lr - 1 Loop lr = lr + 1 Dim a(1 To 16), e For Each e In Split("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20", ",") i = i + 1 a(i) = ws.Range(e).Value Next e sh.Range("C" & lr).Resize(, 16).Value = a Application.ScreenUpdating = True MsgBox "Done", 64 End Sub  

Very bad approach to use macro recorder
Generally try the code that do the same steps
Sub Test() Dim rng As Range, lr As Long With ActiveSheet If .Range("A10").Value = Empty Then MsgBox "Enter Number", vbExclamation: Exit Sub Application.ScreenUpdating = False Set rng = .Range("A10").Resize(, 9) lr = .Cells(Rows.Count, "Z").End(xlUp).Row + 1 .Range("Z" & lr).Resize(, 9).Value = rng.Value rng.SpecialCells(xlCellTypeConstants).ClearContents Application.ScreenUpdating = True End With End Sub  

Hello. Try the following code that is not exactly as you need but give it a try
All the bills will be exported to only one pdf to Desktop instead of creating a pdf for each bill
Sub Export_All_Bills_To_One_PDF() Dim bill, wb As Workbook, wsData As Worksheet, wsBill As Worksheet, wsCounter As Worksheet, shp As Shape, lr As Long, ls As Long, r As Long, m As Long, n As Long Application.ScreenUpdating = False With ThisWorkbook Set wsData = .Worksheets(1): Set wsBill = .Worksheets(2): Set wsCounter = .Worksheets(3) End With lr = wsCounter.Cells(Rows.Count, "A").End(xlUp).Row ls = wsData.Cells(Rows.Count, "B").End(xlUp).Row Set wb = Workbooks.Add(xlWBATWorksheet) For r = 2 To lr wsBill.Range("D1").Value = wsCounter.Cells(r, 1).Value bill = wsBill.Range("A2").Value wsBill.Range("A6:B30").ClearContents: n = 6 For m = 3 To ls If wsData.Cells(m, "B").Value = bill Then wsBill.Range("A" & n).Resize(, 2).Value = wsData.Range("C" & m).Resize(, 2).Value n = n + 1 End If Next m wsBill.Copy After:=wb.Worksheets(wb.Worksheets.Count) With ActiveSheet .Range("A2").Value = .Range("A2").Value .Range("D1").ClearContents For Each shp In .Shapes shp.Delete Next shp End With Next r Application.DisplayAlerts = False wb.Worksheets(1).Delete Application.DisplayAlerts = True wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & "All_Bills.pdf", OpenAfterPublish:=True wb.Close SaveChanges:=False Application.ScreenUpdating = True End Sub  

Try
Sub Test() Dim a, e, ws As Worksheet, sh As Worksheet, i As Long Set ws = ThisWorkbook.Worksheets(1): Set sh = ThisWorkbook.Worksheets(2) a = ws.Range("B11:J" & ws.Cells(Rows.Count, "B").End(xlUp).Row).Value e = sh.Range("Q3").Value For i = LBound(a) To UBound(a) If a(i, 8) = e Then sh.Range("F9").Value = a(i, 2) sh.Range("M9").Value = a(i, 9) Application.Wait Now + TimeValue("00:00:01") Rem sh.PrintOut End If Next i End Sub  

In worksheet module paste the following code
Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Row > 4 And Target.Column = 1 Then x = Application.Match(Target.Value, Sheets(2).Columns(1), 0) If Not IsError(x) Then Target.Offset(, 1).Value = Sheets(2).Cells(x, 2).Value End If End If End Sub  

Try this code
Sub Test() Dim wk As Worksheet, sh As Worksheet, ws As Worksheet, lr As Long Set wk = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) Set ws = CopyWorksheet(wk.Name, wk.Range("B5").Value) Application.ScreenUpdating = False With sh lr = .Cells(Rows.Count, "J").End(xlUp).Row + 1 .Range("B" & lr).Resize(, 5).Value = wk.Range("B5").Resize(, 5).Value .Range("I" & lr).Resize(, 3).Value = Array(wk.Range("D13").Value, wk.Range("D23").Value, wk.Range("D30").Value) .Range("L" & lr).Formula = "=SUM(I" & lr & ":K" & lr & ")" .Range("N" & lr).Value = wk.Range("F41").Value Application.Goto .Range("A1") End With Application.ScreenUpdating = True End Sub Function CopyWorksheet(ByVal sheetName As String, ByVal newName As String) As Worksheet Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False ThisWorkbook.Worksheets(newName).Delete Application.DisplayAlerts = True On Error GoTo 0 ThisWorkbook.Worksheets(sheetName).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ActiveSheet.Name = newName Set CopyWorksheet = ActiveSheet Application.ScreenUpdating = True End Function