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

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

في الحقيقة وصدقني لست بعبقري إنما هو تدريب واجتهاد وبحث في المنتديات و و و .. مجرد اجتهاد بالنسبة للنقطة التي سألت عنها قمت باستخدام دالة Countif وهي دالة العد بشرط .. رأيت أنك تقوم بالعد في المعادلة ولكن النتيجة لم تكن كالمتوقع بالنسبة إليك .. فخطر ببالي أن المشكلة أنك تقوم بالعد بدالة Count فالنتيجة ستكون واحدة لأن الخلايا ليست فراغ إنما الفراغ نتيجة معادلة والفراغ هنا يساوي صفر .. فاستخدمت دالة Countif وأخبرته أن يقوم بالعد للخلايا التي لا تحتوي على الفراغ أو الصفر .. وكلمة لا يساوي تكتب بهذا الشكل <> يعني علامة أقل من ويليها علامة أكبر من ، وتوضع العلامة بين أقواس تنصيص ثم تستخدم أداة الرابط & ثم توضع القيمة أو الشرط 0 بالنسبة للنقطة الثانية أخبرتك أنني أفضل الموضوع أن يكون ذو طلب واحد .. راجع التوجيهات في الموضوع المثبت في صدر المنتدى للمزيد حول الأمر تقبل تحياتي

التنسيق يخفي الأصفار ..جربه مرة أخرى بعد الإطلاع على ملفك جرب المعادلة التالية في الخلية M6 =IFERROR((SUM(D6:F6)-COUNTIF(G6:K6,"<>"&0))*L6+SUM(G6:K6),"")

وعليكم السلام أخي الكريم محمد بالنسبة للنقطة الأولى وهي إخفاء الأصفار يمكن تحديد الخلايا المطلوبة وعمل تنسيق مخصص لها من خلال .. عمل كليك يمين على الخلايا ثم اختر Format Cells ثم من Custom اكتب التالي 0;-0;;@

أخي الكريم عبد العزيز إثراءً للموضوع (ورأيي أن حل أخونا بن علية هو الأفضل) جرب الكود التالي في حدث ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("F2:J2")) Is Nothing Then Dim s As String Dim n As Long Dim i As Long Dim j As Long Const fr As Integer = 12 Const fc As Integer = 12 Const ci As Integer = 4 Application.ScreenUpdating = False Application.EnableEvents = False For i = 12 To 48 Step 4 Range(Cells(12, i), Cells(30, i)).ClearContents Next i s = Replace(Range("F2").Value, " ", "") n = Len(s) For i = 1 To n For j = 1 To n Cells(fr + j - 1, fc + (i - 1) * ci).Value = Mid(s, j, 1) Next j s = Mid(s, 2) & Left(s, 1) Next i Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

أخي الكريم محمود بص بقا دا ملوش علاقة بالإكسيل وأنا متأكد من الكلام اللي بقوله .. لو مش مصدقني جرب بنفسك فيه مفتاح في لوحة المفاتيح اسمه Insert دا أحياناً وإنت بتكتب ممكن تضغط عليه عن طريق الخطأ (ودا وارد .. مش صادر) فتعمل ايه عشان تخلص من المشكلة دي .. بسيطة جداً جدي : تضغط نفس المفتاح تاني (جرب وشوف .. من غير خوف)

بسيطة أخي الكريم في الدالة المعرفة في أول سطر فيها .. هتلاقي آخر كلمة Long استبدلها بكلمة Double للتعامل مع الكسور .. Function SumIfLetter(rng As Range, s As String) As Double وبالنسبة للفاصلة المنقوطة مش خطأ مطبعي ..دا بيرجع لإعدادات الويندوز (أنا بفضل التعامل مع الفاصلة العادية وليست المنقوطة) ويمكن تغييرها كما ترغب

وعليكم السلام أخي الكريم أهلا بيك في المنتدى ونورت بموبايلك .. حاول ترفق ملف في أي موضوع قادم إن شاء الله عموماً جرب الكود التالي .. عله يفي بالغرض إن شاء الله Sub Test() Dim a As Variant Dim i As Long Dim x As Long Dim s As Long Dim e As Long Dim k As Long ReDim a(1 To 100000) For x = 2 To Cells(Rows.Count, 2).End(xlUp).Row If IsNumeric(Cells(x, 2)) And IsNumeric(Cells(x, 3)) And Cells(x, 2) <> 0 And Cells(x, 3) <> 0 Then s = Cells(x, 2).Value: e = Cells(x, 3).Value For i = s To e k = k + 1 a(k) = i Next i End If Next x Range("A2").Resize(k).Value = Application.Transpose(a) End Sub

توضع الدالة في موديول عادي وليس في حدث ورقة العمل عموماً تفضل الملف ودا رابط لفيديو في التعامل مع البدايات لربما لربما يفيدك جمع ثوابت.rar

الحمد لله الذي بنعمته تتم الصالحات .. تقبل تحياتي

جرب الملف المرفق لعله يكون بداية تساعدك على إتمام الأمر Test UserForm.rar

ليس عندي تصور كامل .. انتظر الأخوة بالمنتدى لعل أحدهم لديه فكرة بالموضوع

وعليكم السلام أخي الكريم حارثة تفضل الكود بعد التعديل .. التعديل بسيط في إضافة سطر قرب نهاية الكود وتعديل السطر الذي يليه (وعشان متعبكش ..إليك الكود بالكامل) Option Explicit Sub TransferToRelatedSheets() Dim wks As Worksheet Dim data As Variant Dim item As Variant Dim key As Variant Dim dict As Object Dim rng As Range Dim rngBeg As Range Dim rngEnd As Range Dim cell As Range Dim x As Long Dim y As Long Dim lr As Long Set wks = ThisWorkbook.Worksheets("القوائم") Set rngBeg = wks.Range("A2:H2") Set rngEnd = wks.Cells(Rows.Count, rngBeg.Column).End(xlUp) If rngEnd.Row < rngBeg.Row Then Exit Sub Set rng = wks.Range(rngBeg, rngEnd) Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare Application.ScreenUpdating = False For Each cell In rng.Columns(1).Cells key = Trim(cell) item = cell.Resize(1, rng.Columns.Count).Value item(1, 6) = CLng(item(1, 6)) If Not dict.Exists(key) Then dict.Add key, item Else data = Application.Transpose(dict(key)) x = UBound(data, 1) y = UBound(data, 2) + 1 ReDim Preserve data(1 To x, 1 To y) data = Application.Transpose(data) For x = 1 To UBound(item, 2) data(y, x) = item(1, x) Next x dict(key) = data End If Next cell For Each item In dict.Items If WorksheetExists(CStr(item(1, 1))) Then x = UBound(item, 1) y = UBound(item, 2) lr = Worksheets(CStr(item(1, 1))).Cells(Rows.Count, 1).End(xlUp).Row + 1 Set rng = Worksheets(CStr(item(1, 1))).Range("A" & lr) rng.Resize(x, y).Value = item End If Next item Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub Function WorksheetExists(sheetName As String) As Boolean Dim sheet As Worksheet Dim temp As String temp = UCase(sheetName) WorksheetExists = False For Each sheet In Worksheets If temp = UCase(sheet.Name) Then WorksheetExists = True Exit Function End If Next sheet End Function

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

معادلة ممتازة أخي العزيز سليم ..بارك الله فيك ولا حرمنا الله منك

ألا يوجد خيارات أخرى غير الـ XLS .. ممكن تصدر عدد معين من الصفوف لملف .. وتحدد صفوف أخرى لملف آخر .. وهكذا وبالأكواد يتم تجميع الملفات كلها في ملف واحد (مجرد فكرة)

وعليكم السلام أخي محمد أهلاً بك في المنتدى .. ونورت بين إخوانك أعتقد قد تكون المشكلة في نسخة الأوفيس لديك حيث 2003 فقط هو من يتعامل مع 16384 صف فقط بينما في النسخ الأحدث تتعامل مع ما يتعدى المليون صف .. لذا لو كانت النسخة لديك قديمة قم بتحديثها أو تحديث فوكسبرو (لا أعلم عنه الكثير)

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

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

الحمد لله أن تم المطلوب على خير أخي الكريم حسام .. والحمد لله الذي بنعمته تتم الصالحات تقبل تحياتي

أحوسو .. بتغير في الموضوع ليه .. حاول تركز على الطلب من البداية يا جميل عموماً شوف الكود دا .. ضع الكود في حدث ورقة العمل :: هتقولي إزاي؟ هرد أقولك قلت لك قبل كدا .. Private Sub Worksheet_Change(ByVal Target As Range) Dim arr As Variant Dim temp As Variant Dim x As Variant Dim i As Integer If Target.Cells.Count > 1 Then Exit Sub If Target.Column = 2 And Target.Row > 2 Then Application.EnableEvents = False arr = Array("X", "ص", "م") ReDim temp(1 To 23) x = Application.Match(Target.Value, arr, 0) If Not IsError(x) Then For i = 1 To UBound(temp) temp(i) = arr(x - 1) If x = 3 Then x = 1 Else x = x + 1 Next i End If Target.Offset(, 1).Resize(, UBound(temp)).Value = temp Application.EnableEvents = True End If End Sub

وعليكم السلام أخي أبو حنين

أخي عبد العزيز كنوع من الفضول مش أكتر .. ايه الفايدة من التوزيع بالشكل دا .. تقبل تحياتي

السلام عليكم جرب الدالة المعرفة التالية .. Function SumIfLetter(rng As Range, s As String) As Long Dim arr As Variant Dim itm As Variant arr = rng.Value For Each itm In arr If itm Like "*" & s Then itm = Replace(itm, s, "") If itm = "" Then itm = 1 SumIfLetter = SumIfLetter + itm End If Next itm End Function لاستخدام الدالة المعرفة : ضع الدالة داخل موديول عادي وفي ورقة العمل اكتب المعادلة التالية في الخلية J8 طبقاً لآخر ملف مرفق في آخر مشاركة =SumIfLetter($A$7:$I$7,J6) ثم قم بسحبها لليسار تقبل تحياتي

بارك الله فيك أخي الكريم حارثة نعم يمكن إضافة أسطر للكود لإنشاء أوراق عمل في حالة عدم وجودها ، ولكن أفضل أن يكون هناك ورقة Template كنموذج يتم نسخها ووضع النتائج بها .. الأمر يحتاج لوقت وهو لا يتوفر لي في الوقت الحالي .. إذا كنت تريد هذه الإضافة سأحاول العمل عليها في أقرب وقت إن شاء الله