الـعيدروس

السلام عليكم اخي ابو عبدالرحمن البغدادي اتمنى ان عرفت طريقة العمل عبر مشاركت الاخ والاستاذ ياسر خليل وان لديك ملاحظات اطرحها ولاتتردد تحياتي

السلام عليكم حط الشروط اول الكود وجرب تنفيذ الكود Sub Ali_Sort() Dim Cn_A As String Dim Rn As Range, My_Sort As Range Dim Va_Sp 'xxxxxxxxxxxxxxxxx ' نطاق شروط احرف الفرز Set Rn = [A4:A13] ' نطاق المراد فرز بياناته Set My_Sort = [C1:C13] 'xxxxxxxxxxxxxxxxx With Application .ScreenUpdating = False Cn_A = Join(.Transpose(.Index(Rn.Value, 0)), ",") .AddCustomList ListArray:=My_Sort Va_Sp = .GetCustomListNum(My_Sort.Value) With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=My_Sort, Order:=xlAscending, CustomOrder:="""" & Cn_A & """" .SetRange My_Sort .Apply End With .DeleteCustomList Va_Sp .ScreenUpdating = True End With Set Rn = Nothing: Set My_Sort = Nothing End Sub

السلام عليكم كل مافي الامر اخي وائل بخلت علينا شويه بالشرح اتمنا تحط شرح عملي في ملفك المرفق الاولى غير واضح تماماً والاخرى مبهم برضه

السلام عليكم تفضل Public Sub Alt_Trhil() Dim S As Worksheet T = CStr(Trim([b2])) '' خلية اسم الورقة المراد الترحيل اليها Set S = Sheets(T) With S L = .Cells(.Rows.Count, 7).End(xlUp).Offset(1, 0).Row C = 7 For Each r In ActiveSheet.Range("B3:B26,D2:D26") If C = 31 Then C = C + 1: .Cells(L, C) = r: C = C + 1 Next End With Set S = Nothing End Sub

تلصق الكود في حدث الورقة Private Sub Worksheet_Activate() '' الصفحه المراد السماح بالنسخ With Application .ScreenUpdating = False .Calculation = -4135 Call ToggleCutCopyAndPaste(True) '' .ScreenUpdating = True .Calculation = -4105 End With End Sub وهكذا تلصق الكود في الورقة المراد منع النسخ Private Sub Worksheet_Activate() '' الصفحه المراد منع بالنسخ With Application .ScreenUpdating = False .Calculation = 4135 Call ToggleCutCopyAndPaste(False) '' .ScreenUpdating = True .Calculation = -4105 End With End Sub او هكذا تحط الكود في حدث Thisworkbook حط اسماء الاوراق التي تريد منع النسخ فيها Private Sub Workbook_SheetActivate(ByVal Sh As Object) Select Case Sh.Name Case "ورقة1", "ورقة2", "ورقة3", "ورقة4", "ورقة5", "ورقة6", "ورقة7", "ورقة78" '' الاوراق الذي تود منع النسخ فيها With Application .ScreenUpdating = False .Calculation = 4135 Call ToggleCutCopyAndPaste(False) '' .ScreenUpdating = True .Calculation = -4105 End With Case Else '' With Application .ScreenUpdating = False .Calculation = -4135 Call ToggleCutCopyAndPaste(True) '' .ScreenUpdating = True .Calculation = -4105 End With End Select End Sub

عوداً حميداً اخي ابو تميم تقبل تحياتي وشكري

يمكن جرب هذا التعديل Public Sub Ali_C() For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row If IsDate(Cells(r, 3)) And IsDate(Cells(r, 1)) Then If Application.CountIf(Range("a2:a" & r), Cells(r, 3)) = 0 Then Cells(Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row, 5) = CDate(Cells(r, 3)) End If End If Next r End Sub

السلام عليكم اسعد الله اوقاتك اخي ابو تميم ان شاء الله تكون بأحسن حال الكود الاول لاستخراج اسماء الاوراق عدا الورقة الحاليه مع اضافة هيبرلينك Sub Ali_Ad_H() Dim W As Worksheet r = 2 For Each W In Sheets If Not W.Name = ActiveSheet.Name Then With ActiveSheet .Cells(r, 1) = W.Name .Cells(r, 4) = W.Cells(4, 6) .Cells(r, 1).Hyperlinks.Add Anchor:=.Cells(r, 1), _ Address:="", SubAddress:="'" & W.Name & "'!F4", TextToDisplay:=W.Name r = r + 1 End With End If Next W Set W = Nothing End Sub وهذا كود اخر اخذ اسماء الاوراق حسب العمود A Sub Ali_Ad_H1() Dim W As Worksheet r = 2 For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row Set W = Sheets(CStr(Trim(Cells(i, 1)))) With ActiveSheet .Cells(r, 4) = W.Cells(4, 6) .Cells(r, 1).Hyperlinks.Add Anchor:=.Cells(r, 1), _ Address:="", SubAddress:="'" & W.Name & "'!F4", TextToDisplay:=W.Name r = r + 1 End With Next i Set W = Nothing End Sub

السلام عليكم الاخ والاستاذ ابراهيم ابو ليله اشكرك على مرورك العطر وكلماتك الطيبه تقبل تحياتي وشكري

السلام عليكم استبدل كود CommandButton1_Click بالتالي Private Sub CommandButton1_Click() Dim D As Date Dim D1 As Date Dim Ar, Tx$, y, I, T$, II&, Lr&, V Dim Rng As Range, Rn As Range Dim My_Rn As Range Dim Am Dim Sh As Worksheet Set Sh = Sheets("Sheet1") If Not IsDate(TextBox1) Then MsgBox "حقل تاريخ اعد كتابة التاريخ": TextBox1.SetFocus: Exit Sub If Not IsDate(TextBox2) Then MsgBox "حقل تاريخ اعد كتابة التاريخ": TextBox2.SetFocus: Exit Sub D = DateSerial(Year(TextBox1), Month(TextBox1), Day(TextBox1)) D1 = DateSerial(Year(TextBox2), Month(TextBox2), Day(TextBox2)) Lr = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row II = 2 Set Rng = Sh.Range("c2:c" & Lr) With CreateObject("scripting.dictionary") For R = 2 To Lr If IsDate(Sh.Cells(R, 6)) Then V = DateSerial(Year(Sh.Cells(R, 6)), Month(Sh.Cells(R, 6)), Day(Sh.Cells(R, 6))) If V >= D And V <= D1 Then Set Rn = Sh.Range("C" & R) Tx = Sh.Cells(R, 3) If Not Rn Is Nothing Then If My_Rn Is Nothing Then Set My_Rn = Rn Else Set My_Rn = Union(My_Rn, Rn) End If y = .Item(Tx) End If End If Next R Ar = Split(Join(.Keys, ","), ",") For I = LBound(Ar) To UBound(Ar) If Application.CountIf(My_Rn, Ar(I)) > 0 Then T = T & Ar(I) & " : " & " عدد التكرار ( " & Application.CountIf(My_Rn, Ar(I)) & " ) " & vbNewLine End If Next With UserForm2 .ListBox1.List = Application.Transpose(Split(T, vbNewLine)) End With Set Rn = Nothing: Set My_Rn = Nothing: Set Rng = Nothing End With End Sub تحياتي

السلام عليكم تفضل البحث السريع حسب الورقة_111.rar

السلام عليكم جرب هذا الكود Public Sub Ali_C() For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row If IsDate(Cells(r, 3)) And IsDate(Cells(r, 1)) Then If Application.CountIf(Range("C2:C" & r), Cells(r, 1)) = 0 Then Cells(Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row, 5) = CDate(Cells(r, 3)) End If End If Next r End Sub

هذا الكود جرب حط بيانات في الاوراق المسماه ايراد في جميع الملفات امل ان يعمل معك Sub Ali_Tran_Fil() Dim My_Bok As Workbook Dim Sheet As Worksheet Dim O_Wp As Workbook Dim Sh As Worksheet Dim Ch_Nm As Worksheet Dim Sh1 As Worksheet Dim sht As Worksheet Dim Ths_Nm$, Pth$, F_il$, S_Nm$, Az Dim Lr&, Lrow&, Lss&, Lrr&, ii%, Ar, Ar_O, rr%, pp% Dim My_Vlu As Variant On Error Resume Next Set My_Bok = ThisWorkbook '' Set Sheet = My_Bok.Sheets(1) '' De_Sht CStr(Sheet.Name) ''************** Ths_Nm = "ايراد" '' ''************** Apc_Ali False '-------------------------------------------------------------------- Pth = ThisWorkbook.Path & "\" '' مسار الملفات بنفس مسار الملف الحالي '-------------------------------------------------------------------- F_il = Dir(Pth & "*.xls*") '' xlsx صيغة ملفات الاكسل التي سيتم جلب بياناتها '-------------------------------------------------------------------- '-------------------------------------------------------------------- Do While F_il <> My_Bok.Name S_Nm = Pth & F_il Set O_Wp = Workbooks.Open(S_Nm) '' '-------------------------------------------------------------------- For Each Sh In O_Wp.Worksheets '' Set Ch_Nm = O_Wp.Sheets(Sh.Name) '' If Ch_Nm.Name Like "*" & Ths_Nm & "*" Then With Ch_Nm O_Wp.Activate .Activate .Unprotect Lr = 103 '' Application.Union(.Range("C12:C" & Lr), .Range("A12:A" & Lr), _ .Range("B12:B" & Lr), .Range("F12:F" & Lr), _ .Range("G12:G" & Lr)).Copy End With With Sheet My_Bok.Activate .Activate Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Range("A" & Lrow).PasteSpecial xlPasteValues Lss = .Cells(.Rows.Count, 1).End(xlUp).Row .Range(.Cells(Lrow, 6), .Cells(Lss, 6)) = Split(F_il, ".")(0) & " Sheet_Nm\ " & Ch_Nm.Name End With End If Next Sh '-------------------------------------------------------------------- O_Wp.Close False F_il = Dir Loop With Sheet .Sort.SortFields.Add Key:=.Range("D2", Sheet.Range("D2").End(xlDown)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sheet.Sort .SetRange .Range("A2:F" & .Range("A1").End(xlDown).Row) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With My_Vlu = .Range(.Range("A2"), .Range("A2").End(xlDown).Resize(1, 5)) '' ' '-------------------------------------------------------------------- With CreateObject("scripting.dictionary") For ii = LBound(My_Vlu, 1) To UBound(My_Vlu, 1) '' If My_Vlu(ii, 1) <> "" Then If IsDate(My_Vlu(ii, 4)) Then Date_M = My_Vlu(ii, 4) Dy = .Item(Month(Date_M)) End If End If Next ii Ar = Split(Join(.Keys, ","), ",") '' End With End With ' '-------------------------------------------------------------------- For rr = LBound(Ar) To UBound(Ar) If IsError(Evaluate("'" & Ar(rr) & "'!A1")) Then Set Sh1 = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) With Sh1 .Name = CStr(Ar(rr)) Az = Array("رقم العميل", "العدد", "الصنف", "التاريخ", "السعر", "إسم الملف") With .Range("A1") .Offset(0, 0).Resize(1, UBound(Az) + 1) = Az End With .Columns(1).ColumnWidth = 29.29 .Columns(2).ColumnWidth = 8.43 .Columns(3).ColumnWidth = 15 .Columns(4).ColumnWidth = 16.14 .Columns(5).ColumnWidth = 8.43 .Columns(6).ColumnWidth = 8.43 End With End If Next rr ' '-------------------------------------------------------------------- Ar_O = Sheet.Range("A1").CurrentRegion.Value '' For Each sht In Sheets If Not sht.Index = 1 Then For pp = 1 To UBound(Ar_O, 1) If IsDate(Ar_O(pp, 4)) Then If Trim(Month(Ar_O(pp, 4))) = Trim(sht.Name) Then With sht Lrr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Cells(Lrr, 1) = Ar_O(pp, 1) .Cells(Lrr, 2) = Ar_O(pp, 2) .Cells(Lrr, 3) = Ar_O(pp, 3) .Cells(Lrr, 4) = Ar_O(pp, 4) .Cells(Lrr, 5) = Ar_O(pp, 5) .Cells(Lrr, 6) = Ar_O(pp, 6) End With End If End If Next pp End If Next sht ' '**** Sh_S ' '**** ' '\\\\\\\\ Cr = Split(Sheet.UsedRange.Address, "$")(4) Sheet.Range("A2:F" & IIf(Cr = 1, 2, Cr)).ClearContents '' '//////// Apc_Ali True '' '************************************ Set My_Bok = Nothing: Set Sheet = Nothing: Set O_Wp = Nothing Set Sh = Nothing: Set Ch_Nm = Nothing: Set Sh = Nothing Set Sh1 = Nothing: Set sht = Nothing End Sub Private Sub B_Set(Sh_N()) Dim T_m Dim I, J '---------------------------------- Apc_Ali False For I = LBound(Sh_N) To UBound(Sh_N) For J = I To UBound(Sh_N) If Sh_N(I) > Sh_N(J) Then T_m = Sh_N(I) Sh_N(I) = Sh_N(J) Sh_N(J) = T_m End If Next J Next I Apc_Ali True '---------------------------------- End Sub Private Sub Sh_S() Dim Sht_a As Worksheet Dim My_Sh() Dim I '------------------------------------------ Apc_Ali False ReDim My_Sh(ThisWorkbook.Worksheets.Count) I = LBound(My_Sh) For Each Sht_a In ThisWorkbook.Worksheets My_Sh(I) = Sht_a.Name I = I + 1 Next Sht_a '----------- B_Set My_Sh '----------- For I = LBound(My_Sh) + 1 To UBound(My_Sh) If Sheets(My_Sh(I)).Index <> 1 Then Worksheets(My_Sh(I)).Move After:=Worksheets(ThisWorkbook.Worksheets.Count) End If Next I Apc_Ali True '------------------------------------------ End Sub Public Function De_Sht(ByVal Nm_S As String) Dim Sh_D As Worksheet ''------------------------------------ For Each Sh_D In Worksheets Application.DisplayAlerts = False If Sh_D.Name <> Nm_S Then Sh_D.Delete Application.DisplayAlerts = True Next Sh_D ''------------------------------------ Set Sh_D = Nothing End Function Public Function Apc_Ali(Bll As Boolean) ''------------------------------------ With Application .DisplayAlerts = Bll .Calculation = IIf(Bll, -4105, -4135) .ScreenUpdating = Bll .EnableEvents = Bll End With ''------------------------------------ End Function

بيانات الورقة الاخرى وين تريدها في اي ليست ؟ حسب فهمي شاهد المرفق اضغط زر استدعاء kaled.ra_111.rar

السلام عليكم تفضل الطابعة عند الضغط على الاسم_111.rar

حاولت ازبط كود يقوم بعمل ماتريد الا انه يصل الى ملفك الذي ارفقته مؤخراً ويهنج والى الان لم اكتشف المشكله لي محاولات ان زبطت سوف ارفقها هنا او احد الاساتذه يكمل معك ان لم اجد وقت تحياتي

السلام عليكم اذا لم يتغير عمود الذي به النجمه سهل ارفق الملف وبه الاضافات التي تريدها مع شرح مبسط وابشر ان شاء الله خير تحياتي

السلام عليكم اخي الكريم ابو عبدالرحمن حاول ترفق ملف كمثال وبه المعطيات افضل بدلا مانعمل على شيء ويطلع غير الذي تريد وهكذا نهدر وقت على الفاضي

السلام عليكم حط الاكواد التاليه في حدث الفورم Private Sub CommandButton1_Click() On Error Resume Next Dim Lis, c, cl, Lr, Cm Lr = Range("A13").End(xlDown).Row + 1 With Me.ListBox1 .AddItem For c = 0 To 5 cl = Choose(c + 1, 6, 1, 2, 3, 5, 4) Cm = Me.Controls("TextBox" & cl) .List(UBound(.List), c) = Cm Range("A" & Lr).Offset(0, c) = IIf(IsNumeric(Cm), Val(Cm), CStr(Cm)) Me.Controls("TextBox" & cl) = "" Next c Mx End With On Error GoTo 0 End Sub Private Sub UserForm_Activate() Mx End Sub Private Sub UserForm_Initialize() Dim Rng As Range Set Rng = Range(Range("A13"), Range("A13").End(xlDown).Resize(1, 6)) Me.ListBox1.List = Rng.Value End Sub Private Sub Mx() Dim M M = Application.Max(Range("A:A")) + 1 TextBox6 = M End Sub

اخي مشاكس مانوع الاوفيس عندك 2003 ام 2007 ؟

السلام عليكم هل يوجد ضمن العمود A ايام غير محصوره بالنجمه * يعني ايام عشوائيه ليست منسقه بالسطر الاخضر ؟ ام اكيد ان كل مجموعة سطور ليوم معين يلييها سطر اخضر الخلاصه جرب الكود التالي ينفذ لك الدمج حتى اخر خليه في العمود A بها نجمه Sub Ali_Merg_Data() Dim R As Range Dim Rng As Range Dim My_r As Range Dim X_r As Double On Error Resume Next For Each R In Range("A6:A" & Ali_Last(Range("A6:A2000"), "*")) If R <> "*" Then If Not R Is Nothing Then If Rng Is Nothing Then Set Rng = R Else Set Rng = Union(Rng, R) End If End If Next R 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx If Not Rng Is Nothing Then For Each My_r In Rng.Offset(0, 9).Areas X_r = Alr_Cn(My_r) With My_r .ClearContents .Merge .Value = X_r End With Next End If On Error GoTo 0 Set Rng = Nothing: Set R = Nothing Set My_r = Nothing 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx End Sub Private Function Alr_Cn(R As Range) As Currency Dim i Dim Sm As Double With R For i = 1 To .Rows.Count Sm = Sm + .Cells(i, 1) Next i If Sm Then Alr_Cn = Sm End With End Function Private Function Ali_Last(Rnge As Range, F_Tx$) Dim vv Application.ScreenUpdating = False For vv = Rnge(Rnge.Count).Row To Rnge(1).Row Step -1 If Cells(vv, Rnge.Column) = F_Tx Then Ali_Last = vv Exit Function End If Next vv Application.ScreenUpdating = True End Function

الغينا تفعيل زر الخروج ان شاء الله يعمل معك تفضل المرفق عند الضغد على كلوس يدخل الى البرنامج بدون كتابة رمز الدخول_111.rar

السلام عليكم عبر حدث Close للفورم Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Cancel = True '' غير فعال ' Cancel = False '' فعال End Sub

السلام عليكم اداة الرسائل لها حجم معين من الاسطر لايمكن تجاوزها بالامكان توسعتها بالعرض اي ان كل 10 اسماء بسطر فقط لذا استخدمنا ليست بوكس افضل تفضل المرفق الرشيدى _ إحصاء_222.rar

هل تقصد يوجد بكل ملف 12 ورقة مسماه ايراد - 1 و 2 الخ .. تريد استيرادها الى الملف الحالي وهكذا في باقي الـ 25 ملف الاخر ؟