نجوم المشاركات

اسال الله لي ولكم الجنه واسال الله لفلسطين النصر

تفضل ............................... مستندات.accdb

تفضل استاذ @صايل عزام محاولتي حسب مافهمت . ووافني بالرد . DDTestChamp.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب الحلول التالية ربما هدا ما تقصده Sub test1() Dim crit$, crit2$, F() As String Dim rng As Range, lr As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("Sheet2") ReDim F(1 To 4) 'Bill Type Code ******************************************Action Type & Terminal Type F(1) = "240": F(2) = "2400": F(3) = "26408": F(4) = "293": crit = "DEB": crit2 = "INT" Application.ScreenUpdating = False If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A2:K2") .AutoFilter 3, F, xlFilterValues: .AutoFilter 4, crit, xlFilterValues: .AutoFilter 11, crit2, xlFilterValues lr = WS.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A3:K" & lr).SpecialCells(xlCellTypeVisible) If rng.Cells.Count > 1 Then desWS.Range("A2:F" & Rows.Count).Clear With rng Cpt = Split("A,B,D,J,G,K", ",") ' الاعمدة المرحلة Col = Split("A,B,C,D,E,F", ",") 'الاعمدة المرحل اليها For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "2:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "1") Next i End With End If .AutoFilter Application.ScreenUpdating = True End With End Sub ''''''''''''''''''''''''''''''''''''''' Sub test2() Dim a, i&, k&, F$, S$: F = "DEB": S = "INT" Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("Sheet2") Application.ScreenUpdating = False desWS.Range("A2:F" & Rows.Count).Clear a = WS.Range("A2:K" & WS.[A65000].End(xlUp).Row) For i = 1 To UBound(a) 'Action Type & Terminal Type If a(i, 4) = F And a(i, 11) = S Then ''Bill Type Code If a(i, 3) = "240" Or a(i, 3) = "2400" Or a(i, 3) = "26408" Or a(i, 3) = "293" Then ' الاعمدة المرحلة desWS.Cells(k + 2, 1).Resize(, 6) = Application.IfError(Application.Index(a, i, Array(1, 2, 4, 10, 7, 11)), "") k = k + 1 End If End If Next Application.ScreenUpdating = True End Sub ملف عمليات V1.xlsm

جرب هذا الكود ربما يفي بالمطلوب Sub PrintPDF() Dim AcroRd32ExePath As String Dim PDFFilePath As String Dim cmd As String ' تحديد مسار تطبيق Adobe Acrobat Reader AcroRd32ExePath = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe" ' تحديد مسار الملف PDF الذي تريد طباعته ' هنا نأخذ القيمة من مربع النص TextBox1 PDFFilePath = TextBox1.Value ' إنشاء الأمر الذي سيتم تنفيذه cmd = AcroRd32ExePath & " /n /t " & PDFFilePath ' تنفيذ الأمر Shell cmd, vbHide End Sub

امين يارب العالمين يارب عجل بنصرك الذي وعدت

استاذ @alhourriah للاسف كل هذا بسبب استخدامك للغة العربية في اسماء الجداول النماذج الاستعلامات وغيرها..... وبارامتراتهما ..... فهذا بيلخبط البرمجة غصب عنك وعن أي مبرمج .!!!!!!!!!!

أحييك على الجماليات والفنيات والألوان المبهرات باش مهندس @Foksh 👍🙂 ملاحظات بسيطة 😁 : عند الضغط على اسم البرنامج في شريط الوندوز تظهر شاشة البرنامج الرمادية 🙂 عند الضغط على [غفوة] تظهر رسالة الاستعلام ( أقترح لو تخفيها ) ظهورها مزعج 🙂 عند حذف أحد المنبهات تظل الصفحة ويطلع التالي : بعد الضغط على زر الإغلاق يظل الأكسس شغال في الخلفية 🙂 بالنسبة لنغمة المنبه أقترح تعمل قائمة منسدلة للاختيار من الأصوات المرفقة مع النظام ، وزر لاستعراض الملفات لو حب المستخدم يضيف الملف الصوتي من عنده 🙂 + لون النصوص حبذل لو يكون رمادي فاتح لما تكون الخلفية سوداء لتسهل قرائتها 🙂 هذا وتقبل تحياتي 😊🌹

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 2 قم بتعديل هذا السطر لان البيانات يتم جلبها من ورقة 1 Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") الى Set WS = Worksheets("Sheet2"): Set desWS = Worksheets("Sheet2") او تعديله بالكامل بالشكل التالي Option Explicit Public Sub TransposeData2() Dim desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = desWS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub

تفضل استاذ @sm44ms . DDTestCards.rar

تسلم استاذ @kkhalifa1960 تمام كما المطلوب تقبل تحياتي شكرا الاستاذ الكرام اثابكم الله

بارك الله فيك أستاذى الكريم @ابوخليل هو المطلوب كما اريد بالرابط

ما فهمت منك لحد الساعة هو انك تريد فلترة ونسخ الصفوف مع الارتباط من ورقة Data الى الورقة النشطة تلقائيا بشرط وجود اسم الورقة في الخلية G2 ادا كان هدا هو طلبك ضع اولا الصيغة التالية في الخلية G2 على جميع الاوراق المرغوب نسخ البيانات عليها للتاكد من مطابقة الاسم يمكنك حدفها بعد دالك =MID(@CELL("filename";A1);FIND("]";@CELL("filename";A1))+1;31) وفي حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Activate() Dim lRow2 As Long Set WS = Sheets("data"): Set dest = ActiveSheet If WS.AutoFilterMode Then WS.AutoFilterMode = False lRow2 = WS.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False On Error Resume Next If dest.[G2].Value = dest.Name Then With WS.Range("A2:E" & lRow2) .AutoFilter Field:=5, Criteria1:=dest.[G2].Value Set Rng = WS.Range("A2:E" & lRow2).SpecialCells(xlCellTypeVisible) If Rng.Cells.Count > 1 Then With dest.Range("A2:F" & Rows.Count) .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = xlNone End With Rng.Copy dest.Range("A1") End If .AutoFilter End With End If On Error GoTo 0 End Sub TEST V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لم افهم مادا تقصد بتصفية البيانات في جدول منفصل لاكن على العموم للحصول على النتيجة الظاهرة في الصورة اعلى يكيفي استخدام الكود التالي Option Explicit Public Sub TransposeData() Dim Cpt() As Variant, I As Long, J As Long, k As Long, rng As Variant Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Application.ScreenUpdating = False rng = WS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then WS.Range("C15:D" & Rows.Count).ClearContents WS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) End If Application.ScreenUpdating = True End Sub ولوضعها في جدول يمكنك التعديل على الكود على الشكل التالي هدا مثال لنسخ البيانات على ورقة 2 Option Explicit Public Sub TransposeData2() Dim WS As Worksheet, desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = WS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub تصفية تلقائية V2.xlsb

وعليكم السلام

انظر فيديو مشاركة الاستاذ خليفة ... في هذا الرابط

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

اخواني الكرام اسعد الله اوقاتكم وبعد لو تكرمتم كيف اجعل قيمة الخلية التي تحوي الصيغة ثابتة بعد اول حساب لها حتى لو قمنا بتغيير قيمة الخلايا التي اعتمدنا عليها لحساب الصيغة ؟؟ ارجو ان يكون السؤال واضحا شاكرا تعاونكم وفضلكم