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

تفضل أخي @abouelhassan جرب ووافني بالرد . Out-Get_Table_Excel.rar

لقد حاولت وبفضل الله نجح الامر معي والشكر لجميع أعضاء المنتدى الشكر موصول للأخ Lionhear Option Explicit Sub Get_Data_From_Closed_Workbooks() Dim a, wb As Workbook, ws As Worksheet, sFile As String, sPath As String, lr As Long, m, x, y, z As Long Application.ScreenUpdating = False sPath = ThisWorkbook.Path & "\" & "تقارير" & "\" sFile = Dir(sPath & [k6] & "*" & ".xlsx") m = 9 With Sheet12.Range("b8").CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With Do While sFile <> "" Set wb = Workbooks.Open(sPath & sFile, ReadOnly:=True) Set ws = wb.Sheets(1) With ws lr = .Cells(Rows.Count, "b").End(xlUp).Row a = .Range("b9:o" & lr).Value x = [c6] y = [e6] z = [h6] .Parent.Close False End With Sheet12.Range("b" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a m = m + UBound(a, 1) sFile = Dir() Loop With Sheet12.Range("b9:o" & m - 1) .Borders.Value = 1 End With [c6] = x [e6] = y [h6] = z End Sub

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

تفضل هذا مثال على غرس ملف فك الضغط عن المرفق تجد بجانب قاعدة البيانات ملف باسم ashraf.txt سيتم فتح البرنامج بشكل عادي .... حاول حذف الملف او تغيير اسمه ثم حاول فتح البرنامج Dim iFile Set iFile = CreateObject("Scripting.FileSystemObject") If iFile.FileExists(CurrentProject.Path & "\ashraf.txt") = False Then MsgBox "غير مصرح لك بالدخول .. سيتم غلق البرنامج " DoCmd.Quit Else MsgBox "مرحبا" End If xfolder.rar

الله يبارك فيك ..مبدع

تفضل أخي بطريقتين 1- بمسار أنت تحدده. 2- بمسار القاعدة . تدلل والله معك ثم نحن جميعاً . Out-Get_Table_Excel-Last.accdb

ينفع ليه لا ؟ جرب وحاول .. هناك مائة طريقة وطريقة للحماية 1- كتابة الشفرة داخل محرر الفيجوال ( ثم تحويل الملف الى mde او accde 2 - كتابة الشفرة في الجدول وتشفيرها 3- غرس ملف داخل نظام ويندوز يبحث عنه البرنامج عند الاقلاع فإن وجده فتح 4- البحث عن شفرة معينة داخل ملف في النظام 5- تسجيل قيمة ومفتاح في الريجستري يتعرف عليها البرنامج عند الاقلاع وغيرها الكثير من الطرق المعروفة والخاصة غير المعروفة ، بمعنى انه يمكنك ابتكار طريقة خاصة بك

تم ارسال المرفق جزاك الله خيراً

تم اكمال المثال حسب الأمر بالتسلسل واكتفيت بالصور والمستندات فقط آمل من اخواني التجربة وارسال مرفق لأكثر من شخص ، والافادة بالنتيجة لتفادي المشكلات ان وجدت واعتماده كما اطلب من اخوتي الخبراء فحص الزمن ( sleep) وضبطه ان لزم حتى تظهر عملية الارسال انسيابية محكمة .. لانه حاليا ومن مشاهدتي يوجد تفاوت في السرعة والبطء خلال تنقل الأمر sendwatsWeb2.mdb

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

كيف واشلون فهمتها شتيمه !! ده اختراع!! وكود حل سؤال ..... ( جاوب ) اكمل بين قوسين؟! على درجتين! لا يوجد طلب يخدم لك مشروع ولا نعرف ما هو شرط المطلوب للتحقق او يساوي ده سؤال على بياض

بعد ما انتهي من تحديث! تحديث قادم V4 1-بنافذه متكامله لعرض تقارير 2- تشغيل التقارير من جدول مع تصفيه ارفع برنامج للاكسل مع اكسس

في المثال عبارة عن ترجمة اسماء ....... هل ملفك الاساسي هو ترجمة ام هذا مجرد مثال فقط .....

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

أخي بدون أكواد يمكنك بعد البحث التعدبل بأي حقل .

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

أي دورات أخي لا يوجد بالجدول أي دورات ؟؟؟ ممكن توضح .

اليك هذا المثال not edit.rar

أربط مصدر سجلات التقرير باستعلام .. ومن الاستعلام يمكن التحكم بعدد السجلات

يمكن الاطلاع على الرابط يمكن يفيدك إن شاء الله https://www.officena.net/ib/topic/20819-ترحيل-الى-صفحة-آخرى-على-حسب-لون-الخلية/ https://www.officena.net/ib/topic/53328-ترحيل-اعمده-معينة-بناء-على-لون-خليه-فى-عمود-معين/ كما يمكنك الاطلاع على الرابط التالي أيضا

بعد إذن أخونا محمد يوسف قم بتجربة الكود في الملف التالي والذي سوف يقوم بالحفظ كملف PDF بشكل تلقائي لكل الأسماء الموجودة في القائمة المنسدلة الموجودة في الخلية D3 بيات توزيع المواد الغذائية 002.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ...قد تم اضافة جميع الاكواد الى الملف المرفق Sub AutoF_Data() Dim c As Integer Dim MH As String Dim ws1 As Worksheet, ws2 As Worksheet Dim Y As ListObject, Y1 As ListObject, Y2 As ListObject Dim Lastrow As Long Lastrow = Feuil1.Range("H" & Rows.Count).End(xlUp).Row + 1 'خلية شرط معيار الفلترة MH = Sheets("Sheet1").Range("C1").Value If Len(Range("C1").Value) = 0 Then MsgBox "المرجوا ادخال معيار الفلترة" Exit Sub End If 'افراغ النطاق قبل الترحيل Range("H1:K" & Lastrow).Clear 'جدول البيانات Set ws1 = Sheets("Sheet1") 'مكان وضع البيانات المفلترة Set ws2 = Sheets("sheet1") 'في حالة الرغبة في اضافة شيت جديد وترحيل البيانات اليه 'Set ws2 = Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) 'نسخ الى شيت موجود سابقا 'Set ws2 = Sheets("اسم الشيت") ''''''''''''''الجدول 1 Set Y = ws1.ListObjects(1) Application.ScreenUpdating = False 'تحديد عمود معيار الفلترة Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy 'تحديد موضع اللصق ws2.Cells(3, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''الجدول 2 Set Y = ws1.ListObjects(3) Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy ws2.Cells(12, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''الجدول 3''''''''''''''''''''''' Set Y = ws1.ListObjects(2) Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy ws2.Cells(21, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''نسخ رؤؤس الجداول''''''''''''''''' Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(3, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(12, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(21, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Feuil1.Activate ActiveSheet.ListObjects("Tableau3").Range.AutoFilter Field:=2 ActiveSheet.ListObjects("Tableau2").Range.AutoFilter Field:=2 ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2 'تنسيقات الجداول Call MH3 Application.ScreenUpdating = True End Sub بالتوفيق تصفية في شيت واحد.xlsm

السلام عليكم ورحمة الله محاولة متواضعة في المرفقات... تم إضافة نطاق بالتسمية Rng في ملف "تقارير.xlsb" للنطاق المراد نسخه في ملف "الخزينة.xlsb". الخزينة.xlsb تقارير.xlsb

يمكنك استعمال هذه الدالة المعرفة Function checknum(rng As Range) For n = 1 To 100 If Sqr(rng * n + rng.Offset(0, 1)) = rng.Offset(0, 2) Then checknum = rng.Offset(0, 2): Exit Function End If Next n checknum = 0 End Function ولاستدعاء الدالة نضع في الخلية F2 =checknum(A2) ولا تنس حفظ الملف بصيغة تدعم الماكرو مثل xlsb بالتوفيق

الخلايا المدمجة داخل الجدول (العدو الأول للأكواد والمعادلات ) تجنب استعمالها اذا كان لا بد منها يجب عزلها عن بقية الجدول بصف فارغ(يمكن اخفاءه) في الصورة مثلاً الخلية A127 مدموجة مع الخلبة B127 الخلية A128 مدموجة مع الخلبة B128 و هكذا حتى A136.. ونفس الشيء من A37 الى A46 / من A82 الى A91 الكود المطلوب بعد ازالة دمج الخلايا (الصفحة Salim من هذا الملف) Option Explicit Sub del_data() Dim Ar(), ar_Num() Dim Rg_To_copy, cel As Range Dim My_sh As Worksheet Dim Dic As Object Dim y%, k% Set My_sh = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Ar = Array("B5", "B37", "B50", "B82", "B95", "B127") ar_Num = Array(30, 10, 30, 10, 30, 10) For k = LBound(Ar) To UBound(Ar) For Each cel In My_sh.Range(Ar(k)).Resize(ar_Num(k)) If Not IsEmpty(cel) Then Rg_To_copy = My_sh.Range("B" & cel.Row).Resize(, 7) Rg_To_copy = Application.Transpose(Rg_To_copy) Rg_To_copy = Application.Transpose(Rg_To_copy) Dic(Dic.Count) = Join(Rg_To_copy, "*") End If Next If Dic.Count Then My_sh.Range(Ar(k)).Resize(ar_Num(k), 7).ClearContents For y = 0 To Dic.Count - 1 My_sh.Range(Ar(k)).Offset(y).Resize(, 7).Value = _ Split(Dic.Item(y), "*") Next End If Dic.RemoveAll Next k Set Rg_To_copy = Nothing: Set cel = Nothing Set My_sh = Nothing: Set Dic = Nothing Erase Ar: Erase ar_Num End Sub الملف مرفق salim-coding.xlsm

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة الاصليه المرحله الاولى من هنا موضوع مميز_مرحله اولى قيد يوميه مع الترحيل و كشف حساب بالارصده و المشاركه الثانيه موضوع مميز_مرحله ثانيه كشف حساب برصيد سابق و لاحق_مع يوميه مدين و دائن ثم استكمال و تعديل الموضوع بالمشاركه تحويل دالة SUMPRODUCT إلى كود VBA تم ارفاق كود الحل من الفاضل _ أ / عبدالله باقشير kh_SumProduct (ملف يوميه مع الترصيد الشهرى و كشف الحساب).rar _ و تم تعديل بسيط عليه باضافة استدعاء قيد يومية بواسطة جلال الجمال_ابو أدهم Statement of Account _KH_G.rar و لا تنسونا من صالح الدعاء Statement of Account (18.12.11) After-2 (5).rar Statement of Account (قبل التعديل) (1).rar

و سيتم ان شاء الله اضافة المرحله الرابعه غدا

أخي الحبيب ماجد بما أن البيانات لديك كثيرة فإليك هذا الحل السحري باستخدام المصفوفات Sub CopyDataUsingArrays() Dim A, I As Long, II As Long, N As Long, myDate With Sheets("Inv.History") myDate = .[C2].Value With .[A4].CurrentRegion.Offset(1) .ClearContents A = Sheets("Invoices").Cells(1).CurrentRegion.Value For I = 2 To UBound(A, 1) If A(I, 2) = myDate Then N = N + 1 For II = 1 To UBound(A, 2) A(N, II) = A(I, II) Next End If Next If N > 0 Then .Resize(N).Value = A End With End With End Sub جرب الكود وأعلمنا بالنتيجة ..جرب الكود على الملف الأصلي تقبل تحياتي Invoices V2.rar

السلام عليكم وهذا حل آخر باستخدام كود يعمل الكود من أى صفحة الأولى أو الثانية كما تريد Sub ragab() Dim cl As Range Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = Sheet1: Set ws2 = Sheet2 '==================================================== LR1 = ws1.Cells(Rows.Count, 2).End(xlUp).Row LR2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False ws2.Range("B7:I" & LR2).ClearContents '==================================================== T = 7 Set Rng = ws1.Range("I2:I" & LR1) For Each cl In Rng If cl = "Expire" Then x = cl.Row ws1.Range("B" & x).Resize(1, 8).Copy ws2.Range("B" & T).PasteSpecial xlPasteValues T = T + 1 End If Next Application.CutCopyMode = False Application.ScreenUpdating = True Set ws1 = Nothing: Set ws2 = Nothing End Sub نقل البيانات1.rar

هذا هو الكود Sub OFFICNA() Dim LR As Long, LR2 As Long, ws As Worksheet, ws2 As Worksheet Set ws = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") LR = ws.Range("a" & Rows.Count).End(xlUp).Row LR2 = ws2.Range("a" & Rows.Count).End(xlUp).Row If ws.Range("a2").Value = "" Then MsgBox ("لا توجد بيانات لترحيلها") Else ws.Range("a2:b" & LR).Copy ws2.Range("a" & LR2 + 1) ws2.Select End If End Sub هذا الجزء لتعريف أوراق العمل وتعريفها برمز إختصار اخترت ان يكون ws و ws2 Set ws = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") هذا لتحديد أخر صف فيه بيانات في ورقة العمل المعرفة اختصاراً ws والتي هي Sheet1 LR = ws.Range("a" & Rows.Count).End(xlUp).Row هذا لتحديد أخر صف فيه بيانات في ورقة العمل المعرفة اختصاراً ws2 والتي هي Sheet2 LR2 = ws2.Range("a" & Rows.Count).End(xlUp).Row هذا شرط عدم الترحيل اذا كانت الخلية A2 فاضية وتظهر رسالة تنبيه بعدم التنبيه If ws.Range("a2").Value = "" Then MsgBox ("لا توجد بيانات لترحيلها") في حال عدم تحقق شرط خلو الخلية A2 من البيانات يتم تنفيذ هذا الجزء وهو الخاص بعملية نسخ المدى A2: B مرتبطة بأخر صف فيه بيانات LR ويتم لصقها في ورقة البيانات المسمية WS2 في المدى A وأول صف فارغ في الورقة المرحل اليها ws2 ws.Range("a2:b" & LR).Copy ws2.Range("a" & LR2 + 1) هذا الجزء لاختيار ورقة العمل ws2 بعد الانتهاء من الترحيل ws2.Select ان شاء الله اكون وفقت في الشرح أما بالنسبة لطلبك فهو غير واضح؟؟

لعموم الفائدة هذه تعليقات بسيطة توضح الكود شكرا للأستاذ الحسامى على الكود الرائع Private Sub CommandButton1_Click() Dim rng As Range, rng2 As Range For Each rng In [a1:h17] 'شرط العمل أن تكون الخلية مدموجة If rng.MergeCells = True Then ' المدى rng2 = مكان خلايا منطقة الدمج Set rng2 = rng.MergeArea 'فك الدمج rng.MergeArea.UnMerge ' المدى rng2 كل خلية فيه تساوى قيمة الخلية المدمجة ' يعنى هذا هو سطر النسخ rng2.Value = rng.Value End If Next rng End Sub

السلام عليكم اخي الكريم جرب هذا الحل Dim rng As Range, rng2 As Range For Each rng In [a1:h17] If rng.MergeCells Then Set rng2 = rng.MergeArea rng.MergeArea.UnMerge rng2.Value = rng.Value End If Next rng تحياتي للجميع دمج.rar

السلام عليكم بعد اذن اخي ابو اسامة تم التعديل على كود ابو اسامة ليشمل النطاق c2:o101 مع ظهور رسالة تظهر الارقام وللتاكيد اوالعودة الى القيمة السابقة وهناك زر في المرفق لتفعيل الكود تفضل المرفق sum AA numbers_1.rar

الكود التالي يقوم بإظهار جميع أوراق العمل المخفية دفعة واحد: Sub show() For Each WS In Worksheets WS.Visible = True Next End Sub