محي الدين ابو البشر

ضع هذا المالف في نفس فولدر الملفات التي تريد النسخ إليها Main.xlsm

المشكلة بالمصطلحات التي تستخدمها لا أدري إذا كان هذا ما تقصد Sub test() Range("C3").Resize(Cells(Rows.Count, 3).End(xlUp).Row - 3) _ .SpecialCells(4).Offset(, -1).Resize(, 8).Delete shift:=(xlUp) ActiveSheet.Range("b3:i10").PrintPreview End Sub

Sub filter() Range("B3:I3").Select Selection.AutoFilter ActiveSheet.Range("B3:I3").AutoFilter Field:=2, Criteria1:="<>" ActiveSheet.PrintPreview End Sub

May be? Sub filter() Range("B3:I3").Select Selection.AutoFilter ActiveSheet.Range("B3:I3").AutoFilter Field:=2, Criteria1:="<>" ActiveSheet.PrintPreview Selection.AutoFilter End Sub

عند كتابة رقم الشيت يقتصر البحث في الشيت المكتوب فقط Updated Sub Test() Dim lr1, lr2 Dim i Application.ScreenUpdating = False Cells(5, 1).CurrentRegion.Offset(1).ClearContents For i = IIf(Range("m3") = "", 1, Range("m3")) To IIf(Range("m3") = "", Sheets.Count, Range("m3")) If Range("m3") <> "" Then i = Range("m3").Value + 1 If Sheets(i).Name <> "ÇáÈÍË" Then lr1 = Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets(Sheets(i).Name).Range("A3:L1800").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("A2:L3"), CopyToRange:=Range("A" & lr1 & ":L" & lr1) Cells(lr1, 1).Resize(, 12).Delete lr2 = Cells(Rows.Count, 1).End(xlUp).Row + 1 If lr1 <> lr2 Then Range(Range("a" & lr1), Range("a" & lr1).End(xlDown)).Offset(, 12) = Sheets(i).Name End If: End If Next Range("I10").Select Application.ScreenUpdating = True End Sub

what about Sub Test() Dim lr1, lr2 Dim i Application.ScreenUpdating = False Cells(5, 1).CurrentRegion.Offset(1).ClearContents For i = IIf(Range("m3") = "", 1, Range("m3")) To IIf(Range("m3") = "", Sheets.Count, Range("m3")) If Sheets(i).Name <> "ÇáÈÍË" Then lr1 = Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets(Sheets(i).Name).Range("A3:L1800").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("A2:L3"), CopyToRange:=Range("A" & lr1 & ":L" & lr1) Cells(lr1, 1).Resize(, 12).Delete lr2 = Cells(Rows.Count, 1).End(xlUp).Row + 1 If lr1 <> lr2 Then Range(Range("a" & lr1), Range("a" & lr1).End(xlDown)).Offset(, 12) = Sheets(i).Name End If: End If Next Range("I10").Select Application.ScreenUpdating = True End Sub

السلام عليكم انطلاقاً من الكود الموجود إليك: Sub Test() Dim lr1, lr2 Dim i Application.ScreenUpdating = False Cells(5, 1).CurrentRegion.Offset(1).ClearContents For i = IIf(Range("m3") = "", 1, Range("m3")) To IIf(Range("m3") = "", Sheets.Count - 1, Range("m3")) - 1 With Sheets(CStr(i)) lr1 = Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets(CStr(i)).Range("A3:L1800").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("A2:L3"), CopyToRange:=Range("A" & lr1 & ":L" & lr1) Cells(lr1, 1).Resize(, 12).Delete lr2 = Cells(Rows.Count, 1).End(xlUp).Row + 1 Range(Range("a" & lr1), Range("a" & lr1).End(xlDown)).Offset(, 12) = i End With Next Range("I10").Select Application.ScreenUpdating = True End Sub

هكذا؟ M (1).xlsm

Hi jack305 حسب ما فهمت منك Sub test() Dim a, b As Variant Dim i As Long a = Array(Array("B"), Array("E"), Array("H"), Array("J"), Array("M")) b = Array(Array("E"), Array("H"), Array("K"), Array("N"), Array("Q")) With Sheet1 For i = 0 To 4 If Sheet2.Range(a(i)(0) & 7).Value = 0 Then .Columns((b(i)(0))).EntireColumn.Hidden = True Else .Columns((b(i)(0))).EntireColumn.Hidden = False End If Next End With End Sub

وجة (1).xlsm

اية.xlsm وجة.xlsm

Sub OECUE1() Sheets("haneen").Activate Range("H2").Activate ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 1 ActiveWindow.SelectedSheets.PrintOut Loop While ActiveCell.Value <= Range("x2").Value Range("H2").Activate End Sub هكذا

تغيير بسيط Range("H2").Activate '[H2] = 1 End Sub او احذف جميع [H2]=1 قبل End Sub

وعليكم السلام تغيير بسيط في هذا الجزء If myFile <> "False" Then Sheets("Absence").ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=myFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False 'confirmation message with file info MsgBox "PDF file has been created: " _ & vbCrLf _ تأكد من الفراغات في اسم الشيت ودمتم

الحمد لله أنه تم المطلوب شكراً و بارك الله بكم

تــــم تعديل رفع الملف تسلسل.xlsm

تفضل أخي الكريم NEW1.xlsm

تفضل توضيح (1).xlsm

تفصل أخي الكريم توضيح.xlsm

ربما حسابات 13-2-2021.xlsm

تفضل أخي الكريم Dim LastRow As Long LastRow = LR + 1 With ThisWorkbook.Sheets("DETABEZ") .Range("D" & LastRow) = TextBox1.Value .Range("I" & LastRow) = TextBox2.Value .Range("B" & LastRow) = TextBox3.Value .Range("C" & LastRow) = TextBox4.Value End With ضع هذا في موديول Function LR() As Long Dim ar, tmp, i ar = Array("2", "3", "4", "9") For i = 0 To UBound(ar) - 1 LR = ThisWorkbook.Sheets("DETABEZ").Cells(Rows.Count, CLng(ar(i))).End(xlUp).Row If LR > tmp Then: tmp = LR Next LR = tmp End Function

LastRow = ThisWorkbook.Sheets("DETABEZ").Range("B1000000").End(xlUp).Row

كل الشكر للجميع على هذه الثقة ,أتمنى أن أكو ن على قدر هذه المسئولية Ali Mohamed Ali، ابو طيبه، ابراهيم الحداد، عبدالله الصاري

For Each Rng In Sh.Range("B6:U100") بدل For Each Rng In Sh.UsedRange

ربما؟ تلوين الكلمات.xlsm