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

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

عسى يكون المطلوب استخلاص غ المكرر.xlsm

أكثر اختصاراً Sub test() Dim a As Variant Dim i As Long Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim sh3 As Worksheet Set sh1 = Sheets("sheet1"): Set sh2 = Sheets("sheet2"): Set sh3 = Sheets("sheet3") a = Split(Join(Application.Transpose(sh2.Range("b3:b" & sh2.Cells(Rows.Count, 2).End(xlUp).Row)), "#") _ & "#" & Join(Application.Transpose(sh3.Range("b3:b" & sh3.Cells(Rows.Count, 2).End(xlUp).Row)), "#"), "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If a(i) <> "" Then If Not .exists(a(i)) Then .Add a(i), .Count + 1 End If End If Next sh1.Range(sh1.Range("a3"), sh1.Range("a3").End(xlDown)).Resize(, 2).ClearContents sh1.Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys)) End With End Sub جلب الاسماء من عدة شيتات مع عدم التكرار.xlsm