lionheart

Sub Test() Dim x, ws As Worksheet, sh As Worksheet, r As Long, m As Long, c As Long, n As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Sheet1") Set sh = ThisWorkbook.Worksheets("2") With sh.Range("B2").CurrentRegion.Offset(1) .Cells.UnMerge: .ClearContents End With m = 3 For r = 4 To ws.Cells(Rows.Count, "B").End(xlUp).Row sh.Cells(m, 2).Resize(, 2).Value = ws.Cells(r, 2).Resize(, 2).Value n = 4 For c = 4 To 10 Step 2 sh.Cells(m, n).Value = ws.Cells(r, c).Value sh.Cells(m + 1, n).Value = ws.Cells(r, c + 1).Value n = n + 1 Next c sh.Cells(m, 8).Value = ws.Cells(r, 12).Value For Each x In Array(2, 3, 8) sh.Cells(m, x).Resize(2).Merge Next x m = m + 2 Next r Application.ScreenUpdating = True End Sub

Hello Make sure the direction of language is Arabic before copying the codes and also make sure you have installed Arabic from Windows Settings

Sub Test() Const rAddress As String = "A2:J10" Dim ws As Worksheet, sh As Worksheet, r As Range, m As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("ROW") sh.Cells(1).CurrentRegion.Offset(1).ClearContents For Each ws In ThisWorkbook.Worksheets If ws.Name <> sh.Name Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 Set r = ws.Range(rAddress) sh.Range("A" & m).Resize(r.Rows.Count, r.Columns.Count).Value = r.Value End If Next ws Application.ScreenUpdating = True End Sub

Sub FilterData() Const txt As String = "Your Filter Criteria Here" Dim m As Long Application.ScreenUpdating = False ClearFilter With ActiveSheet m = .Cells(Rows.Count, 4).End(xlUp).Row .Range("A4:S" & m).AutoFilter 4, txt End With Application.ScreenUpdating = True End Sub Private Sub ClearFilter() With ActiveSheet .AutoFilterMode = False If .FilterMode = True Then .ShowAllData End With End Sub

Worksheet module Private Sub TextBox1_Change() SumInTextBox End Sub Private Sub TextBox2_Change() SumInTextBox End Sub Private Sub TextBox3_Change() SumInTextBox End Sub Sub SumInTextBox() Dim m1 As Double, m2 As Double, m3 As Double m1 = Val(TextBox1.Value) * Range("G4").Value m2 = Val(TextBox2.Value) * Range("G6").Value m3 = Val(TextBox3.Value) * Range("G9").Value TextBox4.Value = m1 + m2 + m3 End Sub

Press Alt + F8 and run the code Test Report.xlsm

Remove extra spaces in the months in column A then use this formula =NETWORKDAYS.INTL(1&D4,EOMONTH(1&D4,0),"1111011")

Sub Test() [B6] = GetDupUniq([B3], True) [B9] = GetDupUniq([B3], False) End Sub Function GetDupUniq(ByVal txt As String, ByVal f As Boolean) As String Dim e, s As String, i As Long With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To Len(txt) s = Mid$(txt, i, 1) If s <> " " Then .Item(s) = .Item(s) + 1 Next i For Each e In .Keys If (f = True And .Item(e) = 1) Or (f = False And .Item(e) > 1) Then .Remove e Next e GetDupUniq = Join(.Keys, "-") End With End Function

Sub Test() Const col As Integer = 3 Dim a, e, dic As Object, k As String, i As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") With Sheets(1).Range("A1:AA" & Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row) a = .Columns(col).Resize(, 2).Value For i = 6 To UBound(a, 1) k = a(i, 1) & Space(1) & a(i, 2) If Not dic.Exists(k) Then Set dic(k) = Union(.Rows("1:5"), .Rows(i)) Else Set dic(k) = Union(dic(k), .Rows(i)) End If Next i End With For Each e In dic If Not Evaluate("ISREF('" & e & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = e End If With Sheets(e) .DisplayRightToLeft = True .UsedRange.Clear dic(e).Copy .Cells(1) .Columns.AutoFit End With Next e Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Delete the columns from column AB to column AK first then run the code 1تقرير كامل تشغيل.xlsm

To restrict textbox to numbers only Private Sub TextBox16_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Select Case KeyAscii Case Asc("0") To Asc("9") Case Asc("-") If InStr(1, TextBox16.Text, "-") > 0 Or TextBox16.SelStart > 0 Then KeyAscii = 0 End If Case Asc(".") If InStr(1, TextBox16.Text, ".") > 0 Then KeyAscii = 0 End If Case Else KeyAscii = 0 End Select End Sub As for the other notes, the code is working with no problems

Sub Test() Dim ws As Worksheet, sh As Worksheet, m As Long Application.ScreenUpdating = False Set ws = Sheet1 Set sh = Sheet5 m = ws.Cells(Rows.Count, 2).End(xlUp).Row ws.Range("A3:H" & m).Copy sh.Range("A3").PasteSpecial xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

No way without using VBA

Sub Test() With ActiveSheet .PageSetup.CenterFooter = Format(Date, "dd-mm-yyyy") .PrintPreview End With End Sub

Option Explicit Const col As Long = 4 Private Sub UserForm_Initialize() Dim i As Long With ThisWorkbook.Worksheets(1) If Application.WorksheetFunction.Count(.Columns(col)) > 1 Then For i = 2 To .Cells(Rows.Count, col).End(xlUp).Row ListBox3.AddItem .Cells(i, col).Value Next i End If End With TextBox16.SetFocus End Sub Private Sub TextBox16_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim m As Long If IsNumeric(TextBox16.Value) Then With ThisWorkbook.Worksheets(1) If .Cells(1, col).Value = "" Then .Cells(1, col).Value = Label29.Caption m = .Cells(Rows.Count, col).End(xlUp).Row + 1 .Cells(m, col).Value = TextBox16.Value End With End If With TextBox16 ListBox3.AddItem .Value .Value = Empty TextBox15.Value = ListBox3.ListCount Cancel = True End With End Sub

Private Sub TextBox16_Exit(ByVal Cancel As MSForms.ReturnBoolean) Const col As Long = 6 Dim m As Long If IsNumeric(TextBox16.Value) Then With ThisWorkbook.Worksheets(1) If .Cells(1, col).Value = "" Then .Cells(1, col).Value = Label29.Caption m = .Cells(Rows.Count, col).End(xlUp).Row + 1 .Cells(m, col).Value = TextBox16.Value End With End If With TextBox16 ListBox3.AddItem .Value .Value = Empty Cancel = True End With End Sub

Sub Test() With Range("H1", Range("H" & Rows.Count).End(xlUp)) .AutoFilter 1, "<0" .Offset(1).EntireRow.Delete .AutoFilter End With End Sub

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, m As Long, n As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) m = ws.Cells(Rows.Count, 3).End(xlUp).Row n = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 a = Array(Format(ws.Range("H3").Value, "yyyy/mm/dd"), ws.Range("I2").Value, ws.Range("D3").Value) sh.Range("A" & n).Resize(m - 5, 3).Value = a sh.Range("D" & n).Resize(m - 5, 7).Value = ws.Range("C6").Resize(m - 5, 7).Value Application.ScreenUpdating = True End Sub

Function DigitalRoot(num As String) As Long Dim t As Double t = Val(num) DigitalRoot = IIf(t > 0, 1 + (t - 1) - 9 * Int((t - 1) / 9), 0) End Function =1+MOD(A1-1,9)

Sub TestCode() Dim v, w, m As Long With Sheet1 m = .Columns(3).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row v = .Range("B6:O" & m).Value w = Application.Index(v, Evaluate("ROW(1:" & UBound(v, 1) & ")"), [{1,2,3,14}]) Sheet2.Range("K3").Resize(UBound(v, 1), UBound(v, 2)).Value = w End With End Sub

Sub ADDITEM() Dim x, itemRow As Long, availRow As Long With Sheet2 If .Range("K3").Value = Empty Then Exit Sub Application.EnableEvents = False itemRow = Range("K3").Value availRow = Range("F999").End(xlUp).Row + 1 Range("B4").Value = Sheet4.Range("B" & itemRow).Value Range("D5").Value = Sheet4.Range("D" & itemRow).Value Range("B5").Value = 1 Range("F" & availRow).Value = Range("B4").Value Range("G" & availRow).Value = Range("B5").Value Range("H" & availRow).Value = Range("D5").Value Range("I" & availRow).Value = "=H" & availRow & "*G" & availRow Application.EnableEvents = True End With End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim x, xx, RecptRow As Long If Not Intersect(Target, Range("B3")) Is Nothing And Range("B3").Value <> Empty Then xx = Application.Match(Range("B3"), Sheet4.Columns(1), 0) If Not IsError(xx) Then Range("B4").Value = Sheet4.Cells(xx, 2).Value x = Application.Match(Range("B4").Value, Columns(6), 0) If IsError(x) Then ADDITEM End If If Not Intersect(Target, Range("B5,D5")) Is Nothing And Range("K2").Value = False And Range("K1").Value <> Empty Then x = Application.Match(Range("B4").Value, Columns(6), 0) If IsError(x) Then RecptRow = IIf(Range("K5").Value = 0, Range("K1").Value, Range("K5").Value) Else RecptRow = x End If If Not Intersect(Target, Range("B5")) Is Nothing Then Range("G" & RecptRow).Value = Val(Range("G" & RecptRow).Value) + Target.Value If Not Intersect(Target, Range("D5")) Is Nothing Then Range("H" & RecptRow).Value = Val(Range("H" & RecptRow).Value) + Target.Value End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("f13:i999")) Is Nothing And Range("f" & Target.Row).Value <> Empty Then Range("K1").Value = Target.Row Range("K2").Value = True Range("b4").Value = Range("F" & Target.Row).Value Range("B5").Value = Range("G" & Target.Row).Value Range("D5").Value = Range("H" & Target.Row).Value Range("K2").Value = False End If End Sub