محمد هشام.

Sub TEST_Protect() WS = Array("ورقة1", "ورقة4") On Error Resume Next For i = LBound(WS) To UBound(WS) Sheets(WS(i)).Protect userinterfaceonly:=True, Password:="1234" Next i On Error GoTo 0 End Sub كووود.xlsm

الكاشير 7.xlsm

Sub Transfer() Dim Rng As Range, cl As Range, WS As String Dim C As Long, lastrow As Long Dim WSdata As Worksheet: Set WSdata = Worksheets("Main"): WS = WSdata.[l2] If WSdata.[l2] = 0 Then MsgBox "الرجاء اختيار ورقة العمل", vbOKOnly + vbExclamation, "Admin" Exit Sub End If Dim WSdest As Worksheet: Set WSdest = ThisWorkbook.Sheets(WS) Arr = Array([k5], [k6], [k7], [k8], [k9], [k10], [k11], [k12], [k13], [k14]) For i = 0 To 9 If Arr(i) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(i).Offset(0, -2), vbExclamation, "إنتباه" Arr(i).Select Exit Sub End If Next If MsgBox("ترحيل البيانات الى ورقة " & WSdata.[l2] & " ؟", vbYesNo, "admin") = vbNo Then Exit Sub End If Application.ScreenUpdating = False lastrow = WSdest.[b10000].End(xlUp).Row Set Rng = WSdata.Range("k5,k6,k7,k8,k9,k10,k11,k12,k13,k14") C = 2 For Each cl In Rng cl.Copy WSdest.Cells(lastrow + 1, C).PasteSpecial Paste:=xlPasteValuesAndNumberFormats C = C + 1 Next cl Application.CutCopyMode = False Rng.SpecialCells(xlCellTypeConstants, 23).ClearContents Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح", 64, "تأكيد" End Sub ادخال البيانات2.xlsb

Sub Test_Meragr_Celle() 'دمج Dim LastRow As Long Dim i As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With ActiveSheet LastRow = .Range("c" & .Rows.Count).End(xlUp).Row For i = LastRow To 2 Step -1 If .Range("c" & i).Value = .Range("c" & i - 1).Value Then Application.Union(.Range("c" & i).MergeArea, .Range("c" & i - 1)).Merge End If Next i End With Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub '********************************* Sub annulation_Meragr_Celle() ' الغاء الدمج Dim Rng As Range, xCell As Range Set WorkRng = Range("c2:c" & Cells(Rows.Count, 3).End(xlUp).Row) Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Rng In WorkRng If Rng.MergeCells Then With Rng.MergeArea .UnMerge .Formula = Rng.Formula End With End If Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub اختبار.xlsb

جرب هدا Sub TEST() Dim LR As Long, Formul As String Formul = "=IF(B2="""","""",IF(B2<=9,E2&""0""&C2&""00000""&B2,IF(B2<=99,E2&""0""&C2&""0000""&B2)))" Range("N2:N" & Cells(Rows.Count, 2).End(xlUp).Row) = [Formul] LR = Range("B" & Rows.Count).End(xlUp).Row Range(Range("N2"), Range("N" & LR)).FillDown With Range("N2:N" & LR) .Value = .Value End With End Sub

العفو اخي الكريم يسعدنا اننا استطعنا مساعدتك رغم انني اعتقد ان النسخة السابقة افضل لاكن هده اخر محاولة تم تغيير جميع الاكواد من على اليوزرفورم تمت التجربة على اصدار 2016 و 2010 وتمت العملية بنجاح . النسخة المعدلة.xls

إذن أخي المشكلة في إصدار الأوفيس لديك لهذا يجب أن يكون طلبك على قدر إمكانيات الإصدار المستخدم من طرفك!!!! هل جربت عرض الملفات في النسخة الأولى ام لا؟

لو سمحت ممكن ارفاق صورة للسطر الدي به الخطا مع دكر ما هو اصدار الاوفيس لديك على الجهاز مع العلم ان الملف يشتغل معي بشكل جيد وبدون ادنى مشكلة على نسخة 2021 اليك الرابط التالي https://streamable.com/x84gtp اليك حل اخر 'Private Sub UserForm_Initialize() 'في اخر الكود قم باستبدال الكود الاول بهدا Dim ws, List, tb2(), réf Set ws = PDF List = ws.Range("A2:B" & ws.[A65000].End(xlUp).Row).Value tb2 = Array(1, 2) réf = UBound(tb2) + 1 ' وهدا في حدث التيكست بوكس Private Sub Recherche_Change() a = "*" & Me.Recherche & "*" Dim j(): n = 0 For i = 1 To UBound(List) If List(i, 1) Like a Or List(i, 2) Like a Then n = n + 1: ReDim Preserve j(1 To réf, 1 To n) List(i, 2) = Format(List(i, 2), "dd/mm/yyyy hh:mm") c = 0 For Each k In tb2 c = c + 1: j(c, n) = List(i, k) Next k End If Next i If n > 0 Then Me.ListBox1.Column = j Else Me.ListBox1.Clear End Sub الملف بعد التعديل 4.xls

نعم يتم نسخ بيانات الأعمدة لغاية آخر قيمة على عمود الإسم يمكنك تعديلها بما يناسبك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub مناداة_4() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Dim arr As Variant, k As Variant, Col As Variant, r As Long Set wb = ThisWorkbook: Set wsData = wb.Sheets("control4"): Set wsDest = wb.Sheets("مناداة4") arr = wsData.Range("C10:U" & wsData.Cells(Rows.Count, 6).End(xlUp).Row).Value2 Application.ScreenUpdating = False wsDest.Range("l5:W1000").ClearContents Col = Array(12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23) For Each k In Array(1, 3, 4, 8, 10, 11, 14, 15, 16, 17, 18, 19) wsDest.Cells(5, Col(r)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , k) r = r + 1 Next k Application.ScreenUpdating = True End Sub مصطفي - 2.xlsb

تفضل اخي تم اظافة ورقة مخفية لعرض الملفات الموجودة داخل المجلد على الليست بوكس واستخراج وطباعة اسماء التقارير الغير مرفوعة 'Private Sub UserForm_Initialize() اظافة في nomPDF = "Tableau1" Réf = Range(nomPDF).Columns.Count List = Range(nomPDF).Resize(, Réf + 1).Value For i = 1 To UBound(List): Next i ''''''''''''''''''''''''''''''''' Private Sub Recherche_Change() ling1 = 1 ling2 = 2 clé = "*" & Me.Recherche & "*": n = 0 Dim Tbl() For i = 1 To UBound(List) On Error Resume Next If List(i, ling1) Like clé Or List(i, ling2) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To 2, 1 To n) Tbl(1, n) = List(i, ling1): Tbl(2, n) = (Format((List(i, ling2)), "dd/mm/yyyy hh:mm")) End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear Counter = "عدد التقارير " & "/" & ListBox1.ListCount End Sub بالتوفيق.....🫡 الملف بعد التعديل 3.xls تقرير الحالات.rar

Sub test() Dim j(1 To 2) As String Dim WSData As Worksheet: Set WSData = Sheets("البداية") Dim F As Variant: Set r = WSData.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row) Dim arr() As Variant: arr = r.Value2: F = r.Offset(, 8).Value2 Dim col() As Variant: ReDim col(1 To UBound(arr), 1 To 1) j(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\" j(2) = Dir(j(1)) If j(2) = "" Then MsgBox "يتعدر العثور على مجلد تقرير الحالات ", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" Else Application.ScreenUpdating = False WSData.Range("F7", Range("F" & Rows.Count).End(4)).ClearContents With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) If VBA.Len(F(i, 1)) > 0 And (arr(i, 1)) > 0 Then If Not .Exists(arr(i, 1)) Then .Add arr(i, 1), 1 col(i, 1) = arr(i, 1) Else .Item(arr(i, 1)) = .Item(arr(i, 1)) + 1 col(i, 1) = arr(i, 1) & " (" & .Item(arr(i, 1)) & ")" End If End If Next i r.Offset(, 1).Value2 = col End With Application.ScreenUpdating = True End If End Sub

بعد ادن الاخ المحترم @محي الدين ابو البشر تفضل اخي الكريم تم الاشتغال على اخر نسخة قمت برفعها داخل المشاركة لتحديث ارقام الملفات قم بتشغيل الكود التالي Sub test() Dim j(1 To 2) As String Dim WSData As Worksheet: Set WSData = Sheets("البداية") Dim R As Range: Set R = WSData.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row) Dim AR() As Variant: AR = R.Value2 Dim col() As Variant: ReDim col(1 To UBound(AR), 1 To 1) j(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\" j(2) = Verification j(2) = Dir(j(1)) If j(2) = "" Then ' التحقق من وجود المجلد MsgBox "يتعدر العثور على مجلد تقرير الحالات ", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" Else Application.ScreenUpdating = False Range("F7", Range("F" & Rows.Count).End(4)).ClearContents 'ترقيم الحالات المكررة With CreateObject("Scripting.Dictionary") For i = 1 To UBound(AR) If Not .Exists(AR(i, 1)) Then .Add AR(i, 1), 1 col(i, 1) = AR(i, 1) Else .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1 col(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")" End If Next i '(F) عمود R.Offset(, 1).Value2 = col End With End If Application.ScreenUpdating = True End Sub وفي حدث ورقة البداية ضع الكود التالي تم اظافة رسائل اشعار عند التحقق من عدم وجود مجلد التقارير او عدم وجود رقم التقرير مسبقا داخل المجلد للتجربة يمكنك اما كتابة رقم عشوائي على عمود f او تغيير اسم اي ملف داخل المجلد 😉 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim sh As Worksheet: Set sh = Sheets("البداية") Dim a(1 To 5) As String, FSO As Object, lastrow& lastrow = sh.Columns("F:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 a(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\" a(2) = Search_File: a(3) = réf Cancel = True If Not Intersect(Target, sh.Range("F7:F" & lastrow)) Is Nothing Then If Target.Value = "" Then Exit Sub PDFname = Target.Value: a(2) = PDFname & ".pdf" Set FSO = CreateObject("Scripting.FileSystemObject") a(3) = GetFiles(FSO, a(1), a(2)): a(4) = a(1) & Target.Value & ".pdf" ' التحقق من وجود اسم الملف داخل المجلد If a(3) = "" Then a(5) = " الملف رقم" & " / " & PDFname & " " & " غير موجود " _ & Chr(10) & Chr(10) _ & "" _ MsgBox a(5), vbInformation, "Admin" Exit Sub End If If Dir(a(4)) <> vbNullString Then On Error Resume Next ActiveWorkbook.FollowHyperlink a(4) On Error GoTo 0 End If End If End Sub Public Function GetFiles(ByVal FSO As Object, ByVal Search_Folder As String, ByVal Search_File As String) As String Dim réf1 As Object, réf2 As Object, réf3 As Object If FSO.FolderExists(Search_Folder) Then Set réf2 = FSO.GetFolder(Search_Folder) For Each réf1 In réf2.Files If LCase(réf1.Name) = LCase(Search_File) Then GetFiles = réf1.Path Exit Function End If Next réf1 For Each réf3 In réf2.SubFolders GetFiles = GetFiles(FSO, réf3.Path, Search_File) If GetFiles <> "" Then Exit Function End If Next réf3 End If End Function بالتوفيق... الملف بعد التعديل 2.xls وهده نفس النسخة مع اظافة يوزرفورم لعرض التقارير المسجلة من داخل المجلد مع امكانية فتح الملف او الحفظ وكدالك الطباعة الملف الاصلى والتقارير.rar

نفس معادلة استادنا الفاضل @محمد حسن المحمد =AVERAGEIFS($E$3:E$11;$C$3:C$11;">="&C15;$C$3:C$11;"<"&EOMONTH(C15;0))

Private Sub Workbook_Open() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Protect UserInterfaceOnly:=True, Password:="1234" Next ws End Sub

ربما =TEXTJOIN("";1;MID(A1;SEQUENCE(LEN(A1);;LEN(A1);-1);1)) =TEXTJOIN("";1;MID(A1;ABS(ROW(INDIRECT("1:"&LEN(A1)))-(LEN(A1)+1));1))

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton1_Click() Const TableName As String = "Table5" Const WSdest As String = "Client ACC" Dim StartDate&, EndDate&, LastRow&, Col& Dim Tb1 As ListObject, rng As Range, Customer As String Set Tb1 = Range(TableName).ListObject Customer = Worksheets(WSdest).[H2] StartDate = DateSerial(Year(Date), Month(Date), Day(Date) - 100) EndDate = DateSerial(Year(Date), Month(Date), Day(Date) + 1) Application.ScreenUpdating = False If Me.ComboBox1.Value = "" Then: MsgBox "أختار أسم العميل حتي يمكنك عرض كشف الحساب", vbCritical, "Ah Med": Exit Sub fc = Application.WorksheetFunction.CountIf(DA.Range("B5:B1000"), Me.ComboBox1.Value) fm = Application.WorksheetFunction.CountIf(DA.Range("I5:I1000"), Me.ComboBox1.Value) If fc <= 0 And fm <= 0 Then: MsgBox "أسم العميل غير موجود ", vbCritical, "Ah Med": Exit Sub With Worksheets(WSdest) LastRow = .Cells(.rows.Count, "E").End(xlUp).Row .Range("E17:R" & LastRow).ClearContents .Range("G11:k11,k14").ClearContents .[H2] = Me.ComboBox1.Value: .[G2] = Format(StartDate): .[F2] = Format(EndDate) End With With Tb1 .Range.AutoFilter field:=2, _ Criteria1:=">=" & StartDate, _ Operator:=xlAnd, _ Criteria2:="<=" & EndDate .Range.AutoFilter field:=5, Criteria1:=Me.ComboBox1.Value On Error Resume Next Set rng = Union(.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(3).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(6).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(7).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(9).DataBodyRange.SpecialCells(xlCellTypeVisible)) End With rng.Copy Worksheets(WSdest).[E17].PasteSpecial xlPasteValuesAndNumberFormats [E16].Select Application.CutCopyMode = False Tb1.ShowAutoFilter = False '===== sum total ========= With Worksheets(WSdest) Col = .Cells(.rows.Count, "E").End(xlUp).Row .[G11] = Application.WorksheetFunction.Sum(Range("H17:H" & Col)) .[H11] = Application.WorksheetFunction.Sum(Range("I17:I" & Col)) .[I11] = Application.WorksheetFunction.Sum(Range("J17:J" & Col)) .[J11] = Application.WorksheetFunction.Sum(Range("K17:K" & Col)) .[K11] = .[H11] + .[I11] + .[J11]: .[K14] = .[G11] - .[K11] End With Application.ScreenUpdating = True End Sub Storm - نسخة.rar

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim j, F, Fin&, i&, R& Dim Tb1 As Worksheet: Set Tb1 = Worksheets("control1") Dim Tb2 As Worksheet: Set Tb2 = Worksheets("تقييم عام") F = 1: j = 12 Application.ScreenUpdating = False For Fin = 10 To Tb1.Cells(Tb1.Rows.Count, "c").End(xlUp).Row If Tb1.Range("C" & Fin) <> "" Then Tb2.Range("D" & j) = Tb1.Range("C" & Fin): Tb2.Range("E" & j) = Tb1.Range("E" & Fin) Tb2.Range("F" & j) = Tb1.Range("G" & Fin): Tb2.Range("G" & j) = Tb1.Range("K" & Fin) Tb2.Range("H" & j) = Tb1.Range("L" & Fin) If F = 25 Then j = j + 8: F = 1 Else j = j + 1: F = F + 1 End If End If Next R = 1 For Col = 12 To Tb2.Range("D" & Tb2.Rows.Count).End(xlUp).Row If Tb2.Range("D" & Col) <> "" Then: Tb2.Range("C" & Col) = R: R = R + 1 If R = 26 Then: R = 1 Next Col Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تطبيق على مثالك =IF(AND(A1>=1;A1<=20);1;IF(AND(A1>=21;A1<=31);2;""))

ادن جرب الكود التالي ربما يؤدي المطلوب Sub test() Dim WS As Worksheet: Set WS = ActiveSheet Dim pages As Integer pages = WS.Range("C10") With WS .PageSetup.PrintArea = "$B$2:$D$7" .PrintOut Copies:=pages, Collate:=True End With End Sub نموذج طباعة 3.xlsm

بالرغم انني لا اعلم عن طريقة اشتغالك على الملف لاكن اليك طريقة اخرى ربما تفيدك الطريقة كالتالي https://streamable.com/1kukv8 Public Property Get Sh_Print() As Worksheet: Set Sh_Print = Sheet1 End Property Public Property Get Sh_Table() As Worksheet: Set Sh_Table = Sheet2 End Property Sub To_print() TbPage = Sh_Table.[Tb_MiseEnPage] NbMax = UBound(TbPage) Cpt = Application.InputBox(Prompt:=" المرجوا ادخال رقم الستيكر المرغوب طباعتها (من 0 الى " & NbMax & ")", Title:="طباعة", Type:=1) Cpt = Int(Cpt) If Cpt < 1 Then Exit Sub If Cpt > NbMax Then: MsgBox "اخر سكيرت على الملف هي :" & " " & NbMax, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "تنبيه": Exit Sub With Sh_Print .PageSetup.PrintArea = "" For i = 1 To Cpt With .PageSetup .PrintArea = TbPage(i, 7) & ":" & TbPage(i, 8) Copies = TbPage(i, 6) If Copies < 1 Then Copies = 1 .FitToPagesWide = 1 .FitToPagesTall = 1 End With Next End With Sh_Print.PrintOut Copies:=Copies End Sub نموذج طباعة.xlsm

فقط مجرد احتمال على العموم وفقنا الله واياكم لما يحب ويرضى كود جميل ومختصر .شكرا لك

جرب هدا على ما اظن بعد تعيين حدود الطباعة بالشكل الدي يناسبك Sub test() ActiveSheet.PrintOut Copies:=ActiveSheet.Range("c10").Value, IgnorePrintAreas:=False End Sub

Option Explicit Public Property Get WSData() As Worksheet: Set WSData = Sheets("ورقة1") End Property Public Property Get WSDest() As Worksheet: Set WSDest = Sheets("ورقة2") End Property '***' اظافة مربعات الاختيار عند التحقق من وجود قيمة في عمود الاسم Sub Add_CheckBoxes() Dim cell, col As Single, Cpt As CheckBox Dim MyLeft, MyTop, MyHeight, MyWidth As Double Application.ScreenUpdating = False col = WSData.Range("B" & Rows.Count).End(xlUp).Row WSData.CheckBoxes.Delete For cell = 2 To col If WSData.Cells(cell, "B").Value <> "" Then MyLeft = Cells(cell, "A").Left: MyTop = Cells(cell, "A").Top MyHeight = Cells(cell, "A").Height: MyWidth = Cells(cell, "A").Width WSData.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select With Selection .Caption = "": .Value = xlOff: .Display3DShading = False End With [A1].Select End If Next cell Application.ScreenUpdating = True End Sub '**** نسخ الاعمدة المحددة Sub CopyRows() Dim derlig&, r&, Lr&, Cpt As CheckBox For Each Cpt In WSData.CheckBoxes If Cpt.Value = 1 Then For r = 1 To Rows.Count If Cells(r, 1).Top = Cpt.Top Then With WSDest .Range("A2:A" & Rows.Count).ClearContents Lr = .Range("B" & Rows.Count).End(xlUp).Row + 1 ' عمود الاسم .Range("B" & Lr) = _ WSData.Range("B" & r).Value 'في حالة الرغبة بنسخ عدة اعمدة قم بظبط السطر التالي بما يناسبك ' .Range("B" & Lr & ":F" & Lr) = _ ' WSData.Range("B" & r & ":F" & r).Value '**** تسلسل البيانات المنسوخة derlig = WSDest.Range("B" & WSDest.Rows.Count).End(xlUp).Row WSDest.Range("A2").Value = 1 WSDest.Range("A2:A" & derlig).DataSeries , xlDataSeriesLinear End With Exit For End If Next r End If Next On Error Resume Next WSData.CheckBoxes.Value = False On Error GoTo 0 End Sub Microsoft Excel Worksheet جديد (2).xlsm

ربما تحتاج الى تفعيل وحدات الماكرو لديك على العموم هل تريد نسخ عمود الاسم فقط مع مزيدا من التوضيح هل البيانات المنسوخة يتم الاحتفاظ بها رغم الغاء التحديد او حدفها هل تريد مثلا تحديد عدة صفوف وترحيلها دفعة واحدة