lionheart

This formula returns only the results that match the criteria and not all the dates =TEXTJOIN("-",TRUE,IF(الحركة!$A$2:$A$10=A2,الحركة!$F$2:$F$10,""))

Using formulas ------------------- Column F Formula =TEXTJOIN("-",TRUE,IF(الحركة!$A$2:$A$10=A2,الحركة!$F$2:$F$10,"")) Column G Formula =IFERROR(LOOKUP(2,1/(الحركة!$A$2:$A$10=A2),الحركة!$J$2:$J$10),"") Using VBA -------------- Sub Test() Dim ws As Worksheet, sh As Worksheet, rng As Range, n As Long, r As Long Set ws = ThisWorkbook.Worksheets(2) Set sh = ThisWorkbook.Worksheets(3) Set rng = ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row) n = sh.Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To n sh.Cells(r, 6).Value = MyVLOOKUP(sh.Cells(r, 1).Value, rng, 6, "-") sh.Cells(r, 7).Value = LookupLast(sh.Cells(r, 1).Value, rng, 10) Next r End Sub Function MyVLOOKUP(ByVal myVal, ByVal rng As Range, ByVal colRef As Long, ByVal myStr As String) If Not IsNumeric(myVal) Then myVal = Chr(34) & myVal & Chr(34) With rng MyVLOOKUP = Join(Filter(.Parent.Evaluate("TRANSPOSE(IF(" & .Columns(1).Address & "=" & myVal & "," & .Columns(colRef).Address & "))"), False, 0), myStr) End With End Function Function LookupLast(ByVal txt As String, ByVal rng As Range, ByVal col As Integer) Dim i As Long For i = rng.Columns(1).Cells.Count To 1 Step -1 If txt = rng.Cells(i, 1) Then LookupLast = rng.Cells(i, col): Exit Function Next i End Function

If Txt3 <> "" Then --------- --------- Else GoTo NXT End If NXT: Dim lastrow As Long

In cell K2 insert the formula then drag =ROUNDUP(C2,0)

I didn't see that point when started to work on the problem. Generally, it will not be harmful to let the OP try the code too

Rem In UserForm Module Rem ------------------ Private Sub UserForm_Initialize() Dim a With ThisWorkbook.Worksheets(1) a = MergeRanges(.Range("AH2").Resize(Application.CountA(.Columns("AH"))), .Range("W2").Resize(Application.CountA(.Columns("W")))) End With Me.ComboBox1.List = a End Sub Rem In Standard Module Rem ------------------ Function MergeRanges(ParamArray args()) Dim e, cell As Range ReDim temp(0) For Each e In args For Each cell In e If cell <> "" Then temp(UBound(temp)) = cell ReDim Preserve temp(UBound(temp) + 1) End If Next cell Next e ReDim Preserve temp(UBound(temp) - 1) MergeRanges = Application.Transpose(temp) End Function

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