ياسر خليل أبو البراء

وعليكم السلام أخي الكريم أبو عبد الواحد في الملف المسمى "السجل" أدرج موديول جديد وضع الكود التالي فيه Sub ImportDataFromClosedWBs_YasserKhalil() Dim strFolder As String Dim strFile As String Dim wbk As Workbook Dim sh As Worksheet Dim lr As Long With Application .ScreenUpdating = False .Calculation = xlManual .DisplayAlerts = False .AskToUpdateLinks = False End With strFolder = ThisWorkbook.Path & "\الفواتير\" strFile = Dir(strFolder & "*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open(strFolder & strFile) Set sh = wbk.Worksheets(1) With ThisWorkbook.Worksheets(1) lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("A" & lr).Resize(1, 6).Value = sh.Range("A7").Resize(1, 6).Value .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value End With wbk.Close False strFile = Dir Loop With Application .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub

اطلعت على الملف وحاولت فهم المطلوب . ومع الرغم من كثرة التفاصيل التي ذكرتها إلا أن الموضوع مبهم (خصوصاً أنك ذكرت أنك لا تريد كود لإخفاء الجداول الفارغة) المطلوب يلزمه كود ليقوم بعملية الإخفاء للصفوف الغير مرغوب فيها .. حاول ترفق شكل الورقة بعد إخفاء الجداول الغير مرغوب فيها كنموذج للإطلاع عليه

بارك الله فيك أخي العزيز سليم إثراءً للموضوع إليك حل المشكلة بثلاثة طرق الأولى بطريقة يدوية بالشكل التالي والطريقة الثانية نفس الفكرة بالكود بدون حلقات تكرارية Sub SimpleReplace() With Columns(2) .Replace "2017", "", xlPart .Replace "~*", "", xlPart End With End Sub والطريقة الثالثة باستخدام المعادلات حيث يمكنك وضع المعادلة التالية في أي عمود فارغ بهذا الشكل =SUBSTITUTE(SUBSTITUTE(B1,"2017",""),"*","")

السلام عليكم حاولت الإطلاع على الملف ولكنه لا يفتح .. قم بإزالة الأكواد الموجودة لديك وارفع الملف مرة أخرى لربما تجد من يساعدك بالأمر إن شاء الله

وعليكم السلام أخي الكريم أبو حمادة ارفق ملف ليعمل عليه الأخوة الكرام حيث الموضوع مع إرفاق ملف يكون أجدر بسرعة الاستجابة

إن شاء الله أحاول العمل على هذه النقطة ليلاً لأن الوقت قد أوشك على الإفطار وكل عام وأنت بخير

الفكرة في البحث عن الاسم في ورقة العمل "يناير" في العمود الثاني ثم بالاعتماد على رقم الصف يتم اختبار العمود AT فإذا كان لا يساوي القيمة 1 يتم عمل الكود والطباعة .. وجزيت خيراً بمثل ما دعوت لي وكل عام وأنت بخير

بسم الله ما شاء الله دائماً ما تتحفنا بأشياء وموضوعات رائعة .. والله إنها لكنوز بارك الله فيك أخي الغالي خالد الرشيدي وجزيت خير الجزاء في الدنيا والآخرة وكل عام وأنت بخير

السلام عليكم جرب التعديل التالي .. في كود طباعة كل الشهادات Sub pallshehadat() Dim x As Variant Application.ScreenUpdating = False ActiveSheet.PageSetup.Zoom = 80 ActiveSheet.PageSetup.PrintArea = "$B$8:$I$35" Range("C2").Select ActiveCell.FormulaR1C1 = "1" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 1 x = Application.Match(Range("B15"), Sheets("يناير").Columns(2), 0) If Not IsError(Application.Match(Range("B15"), Sheets("يناير").Columns(2), 0)) Then If Sheets("يناير").Cells(x, "AT").Value <> 1 Then ActiveWindow.SelectedSheets.PrintOut End If End If Loop Until ActiveCell.Value = Range("C3").Value Range("C13").Select Application.ScreenUpdating = True End Sub

وعليكم السلام بفرض أن لديك UserForm1 ويوجد زر أمر CommanButton1 يمكنك استخدام الكود بهذا الشكل Private Sub CommandButton1_Click() Unload Me Sheets("Sheet2").Activate End Sub حيث Sheet2 هو اسم ورقة العمل المطلوب الانتقال إليها

أخي الكريم .. اطلعت على الكود في ملفك ووجدت أنك لم تقم بعملية نسخ الكود بشكل صحيح .. حيث يوجد حروف باللغة العربية داخل الكود لذا يجب عند نسخ الكود من المنتدى أن يكون اتجاه الكتابة باللغة العربية لكي يتم نسخ اللغة العربية في الكود بشكل صحيح ملحوظة أخرى يفضل إدراج موديول جديد ووضع الكود فيه وليس وضعه في حدث ورقة العمل جرب مرة أخرى وأعملني بالنتيجة

جرب التعديل التالي عله يفي بالغرض (ويرجى فيما بعد حين تطرح موضوع أن ترفق الملف الأصلي أو ملف معبر عنه تماماً لكي يسير العمل بشكل منتظم وكما هو مطلوب ومتوقع) Sub Test() Dim arr As Variant Dim arBr As Variant Dim arLu As Variant Dim arDi As Variant Dim i As Long Dim j As Long Dim b As Long Dim l As Long Dim d As Long arr = Range("A116:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim arBr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) ReDim arLu(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) ReDim arDi(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) For i = 1 To UBound(arr, 1) If arr(i, 4) = "ص" Then b = b + 1 For j = 1 To 3 arBr(b, j) = arr(i, j) Next j arBr(b, 4) = arBr(b, 2) * arBr(b, 3) ElseIf arr(i, 4) = "غ" Then l = l + 1 For j = 1 To 3 arLu(l, j) = arr(i, j) Next j arLu(l, 4) = arLu(l, 2) * arLu(l, 3) ElseIf arr(i, 4) = "ع" Then d = d + 1 For j = 1 To 3 arDi(d, j) = arr(i, j) Next j arDi(d, 4) = arDi(d, 2) * arDi(d, 3) ElseIf arr(i, 4) = "م" Then l = l + 1 d = d + 1 For j = 1 To 3 arLu(l, j) = arr(i, j) arDi(d, j) = arr(i, j) Next j arLu(l, 2) = Application.WorksheetFunction.Round(arLu(l, 2) * 2 / 3, 2) arDi(d, 2) = Application.WorksheetFunction.Round(arDi(d, 2) * 1 / 3, 2) arLu(l, 4) = arLu(l, 2) * arLu(l, 3) arDi(d, 4) = arDi(d, 2) * arDi(d, 3) End If Next i Range("B15").Resize(b, UBound(arBr, 2)).Value = arBr Range("B24").Resize(l, UBound(arLu, 2)).Value = arLu Range("B65").Resize(d, UBound(arDi, 2)).Value = arDi End Sub

يتعذر العمل على الجهاز بشكل كامل الآن .. إن شاء الله إذا لم يتدخل أحد الأخوة سأحاول العمل عليه ليلاً أو غداً إن شاء الله وأريد توضيح بمثال لشرط المناصفة لتتضح الصورة ..

وعليكم السلام ورحمة الله وبركاته إذا أردت جعل الحلقة التكرارية مرنة قم باستبدال الرقم 11 والذي يمثل رقم آخر فهرس بالمصنف بالجملة Worksheets.Count وكل عام وأنت بخير

وعليكم السلام جرب الكود التالي .. وكل عام وأنت بخير أخي الكريم محمد Sub CreateFolderOnDesktop() Dim strDir As String strDir = Environ("USERPROFILE") & "\Desktop\Test\" If Dir(strDir, vbDirectory) = "" Then MkDir strDir Else MsgBox "Directory Exists", 64 End If End Sub

مجرد اقتراح لما لا تقوم بترتيب البيانات في ورقة واحدة فقط وهي ورقة العمل الرئيسية ثم سيعمل الكود الأصلي بدون مشاكل إن شاء الله .. مجرد اقتراح يسهل عليك حل المشكلة بشكل كبير أما بخصوص الخطأ لا أدري سببه ولكن يمكن تجنب الخطأ الوارد باستخدام جملة On Error Resume Next في بداية الكود

تفضل أخي العزيز أبو عبد الرحمن كود يقوم بالترتيب لأوراق العمل من الفهرس رقم 2 إلى رقم 11 ... Sub SortSheets() Dim i As Long Dim r As Long For i = 2 To 11 With Worksheets(i) r = .Range("A7").CurrentRegion.Rows.Count + 5 .Range("A7").CurrentRegion.Offset(2).Sort Key1:=.Range("F8:F" & r), Order1:=xlAscending, Header:=xlNo End With Next i End Sub

ارفق الملف الذي يظهر به الخطأ لأن الكود مجرب ويعمل بشكل جيد على الملف في المشاركة الأصلية للموضوع ..

جرب الكود التالي لعله يفي بالغرض Sub Test() Dim arr As Variant Dim arBr As Variant Dim arLu As Variant Dim arDi As Variant Dim i As Long Dim j As Long Dim b As Long Dim l As Long Dim d As Long arr = Range("A117:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim arBr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) ReDim arLu(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) ReDim arDi(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1) For i = 1 To UBound(arr, 1) If arr(i, 5) = "ص" Then b = b + 1 For j = 1 To 3 arBr(b, j) = arr(i, j) Next j arBr(b, 4) = arBr(b, 2) * arBr(b, 3) ElseIf arr(i, 5) = "غ" Then l = l + 1 For j = 1 To 3 arLu(l, j) = arr(i, j) Next j arLu(l, 4) = arLu(l, 2) * arLu(l, 3) ElseIf arr(i, 5) = "ع" Then d = d + 1 For j = 1 To 3 arDi(d, j) = arr(i, j) Next j arDi(d, 4) = arDi(d, 2) * arDi(d, 3) ElseIf arr(i, 5) = "م" Then l = l + 1 d = d + 1 For j = 1 To 3 arLu(l, j) = arr(i, j) arDi(d, j) = arr(i, j) Next j arLu(l, 4) = arLu(l, 2) * arLu(l, 3) arDi(d, 4) = arDi(d, 2) * arDi(d, 3) End If Next i Range("B16").Resize(b, UBound(arBr, 2)).Value = arBr Range("B26").Resize(l, UBound(arLu, 2)).Value = arLu Range("B67").Resize(d, UBound(arDi, 2)).Value = arDi End Sub

السلام عليكم ممكن مزيد من التفاصيل حول المطلوب حيث اطلعت على الملف ولم أفهم المطلوب بشكل كامل

وعليكم السلام أخي الغالي بن عليه كل عام وأنت بخير حاولت الإطلاع على الكود لمعرفة المطلوب من خلال الكود ولكن عند دراسة الكود حيرني هذا الجزء .. For I = 5 To K J = Application.Match(Cells(K, "L").Value, Array("الاول", "الثانى", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر"), 0) Cells(K, "M").Value = J Next I حيث في الحلقة التكرارية تم استخدام المتغير I ولكن لم يتم استخدامه داخل الحلقة التكرارية وهذا أمر حيرني .. أهناك حكمة من ذلك أم أن المتغير I يجب استخدامه بدلاً من المتغير K في كلا السطرين داخل الحلقة التكرارية تقبل تحياتي

في الكود السابق غير السطر التالي Cells(i, "C").Resize(, 2).Delete xlUp لصيبح بالشكل التالي Cells(i, "]").Delete xlUp

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

جرب الكود بهذا الشكل Private Sub CommandButton4_Click() Dim lastRow As Long Dim i As Long lastRow = Range("C" & Rows.Count).End(xlUp).Row For i = lastRow To 1 Step -1 If Cells(i, "D").Value = "" Then Cells(i, "C").Resize(, 2).Delete xlUp End If Next i End Sub

وعليكم السلام ما هو المنطق في عملية التوزيع ؟ يرجى تفصيل مثال أو مثالين لتتضح الصورة ...