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

رائع استاذ بن علية لكن اذا كنت تريد نقل التنسيق ايضاً يمكن استعمال هذا الكود حلقة تكرارية واحدة (ربما يكون أسرع للبيانات الكبيرة) مع امكانية ادراج صف فارغ أو لا (بعد نسخ البيانات) من خلال الاجابة عن سؤال Yes Or No Option Explicit Sub All_in_on_New() With Sheets("Sheet1") Dim my_rg As Range, N_col%, x% Dim k%: k = 2 Dim sub_rg As Range Dim Answer As Byte .Range("j2:j" & Rows.Count).Clear Set my_rg = .Range("a2").CurrentRegion N_col = my_rg.Columns.Count Answer = MsgBox(" Your Data With Empty Row Between Or NO??", 4) For x = 1 To N_col Set sub_rg = my_rg.Columns(x).SpecialCells(2, 23) sub_rg.Copy Cells(k, "j") k = k + sub_rg.Cells.Count + (7 - Answer) Next End With End Sub الملف مرفق Write_in_one_co_New.xlsm

جرب هذا الماكرو Option Explicit Sub All_in_on() With Sheets("sheet1") Dim my_rg As Range, N_col%, N_Row%, x% Dim t%, k%: k = 2 Set my_rg = .Range("a2").CurrentRegion .Range("j2", Range("j1").End(4)).ClearContents N_col = my_rg.Columns.Count N_Row = my_rg.Rows.Count For x = 1 To N_col For t = 1 To N_Row If Not IsEmpty(my_rg.Cells(t, x)) Then .Cells(k, "J") = my_rg.Cells(t, x) k = k + 1 End If Next Next End With End Sub الملف مرفق Write_in_one_col.xlsm

السلام عليكم ورحمة الله وهذا كود آخر في المرفق يقوم بجمع قيم خلايا الأعمدة من A إلى F في العمود M بداية من الصف الثاني مع نسخ لون خلايا هذه القيم (والكود لا يعتبر الخلايا الفارغة في الأعمودة)... بن علية حاجي New Microsoft Excel Worksheet (1).xlsm

السلام عليكم ورحمة الله أخي الكريم تفضل جرب الكود التالي Sub nn() For sh = 1 To Sheets.Count With Sheets(sh) LR = .[C9999].End(xlUp).Row .Range("A" & LR & ":H" & LR).Copy .[A17].PasteSpecial xlPasteValues With .Range("A18:H" & LR) .ClearContents .Interior.ColorIndex = xlNone End With End With Next sh End Sub ومرفق أيضا الملف وبه الكود اصناف2.xlsm

الاخ @Taaiy وبعد اذن الاستاذ ابا خليل هذا لتمرير الباراميتر في امر فتح الاستعلام Private Sub أمر0_Click() DoCmd.SetParameter "[ادخل رقم الشهر]", "1" DoCmd.SetWarnings False DoCmd.OpenQuery "2" DoCmd.SetWarnings True End Sub بالتوفيق

السلام عليكم اضع بين ايديكم هذا العمل المتواضع لاستخراج كشف حساب عميل تفصيلي ويكفيني منكم جزاكم الله خيرا كشف حساب عميل 2018.rar

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

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

السلام عليكم ورحمة الله وبركاته اثراء للموضوع وبعد اذن الاستاذ طارق محمود اخفاء السطر-1.xlsm

السلام عليكم الأفضل تضع كل الحالات لذلك وضعت لك الحل من خلال أكثر من كود واحد الأول : عند تنشيط الورقة وهذا يراجع الصفوف من 15 إلي آخر صف ويخفي السطر أوتوماتيكيا بشرطين أن I=0 ، G<>0 أي يكون هناك سداد الثاني : عند حدث تنشيط الورقة وهذا يراجع الصفوف من 15 إلي آخر صف ويخفي السطر أوتوماتيكيا بشرطين أن I=0 ، G<>0 أي يكون هناك سداد الثالث : Un-Hide كود عادي ليس خاص بأحداث الورقة وهذا يظهر كل السطور التي تم إخفاؤها من قبل بالإضافة إلي كود رابع في حدث الملف عند فتح الملف يتم تفعيل الكود الأول إليك الأكواد والملف به الأكواد Private Sub Worksheet_Activate() LR = [I9999].End(xlUp).Row If LR < 15 Then LR = 15 For r = 15 To LR If Cells(r, "I") = 0 And Cells(r, "G") <> 0 Then Rows(r).EntireRow.Hidden = True Next r End Sub Private Sub Worksheet_Change(ByVal Target As Range) r = Target.Row If Cells(r, "I") = 0 And Cells(r, "G") <> 0 Then Rows(r).EntireRow.Hidden = True End Sub Sub un_Hide() LR = [I9999].End(xlUp).Row Rows(10 & ":" & LR).EntireRow.Hidden = False End Sub '=============================================================== Private Sub Workbook_Open() Sheets ("كشف الحساب ") LR = [I9999].End(xlUp).Row If LR < 15 Then LR = 15 For r = 15 To LR If Cells(r, "I") = 0 And Cells(r, "G") <> 0 Then Rows(r).EntireRow.Hidden = True Next r End Sub اخفاء السطر.xlsm

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

ها هو المثال استاذ @صالح حمادي jpg.rar

ضع الكود ده .. في مودول .. وجرب ان شاء الله يفي بالغرض ... Option Explicit Sub Print_by_number() 'في حالة الطباعة بدون معاينة Dim m As Integer m = InputBox("كم نسخة تريد طباعتها : ", "اوفيسنا ") ActiveSheet.PrintOut Copies:=m, Collate:=True Range("b5").Activate End Sub Sub Print_by_number2() 'في حالة الطباعة بمعاينة Dim m As Integer m = InputBox("كم نسخة تريد طباعتها : ", "اوفيسنا ") ActiveSheet.PrintOut Copies:=m, Preview:=True, Collate:=True Range("b5").Activate End Sub

See this video https://www.youtube.com/watch?v=NyyQ8WcM8_w

استاذ جعفر السلام عليكم شكرا جزيلا على البرنامج فهو برنامج كبير الحجم وبه كثير من الاكواد ممكن نقدر نغير برنامج الماسح المسمى (NAPS2) المرفق مع البرنامج بعاليه باي برنامج اخر ويتم ربطه ايضا بالاكسس مثلا هذا البرنامج المرفق المسمى (WinScan2PDF) ممكن نقدر نربطه بالقاعدة المرفقة ايضا اقصد بالربط هو بعد السحب من البرنامج يتم ادراج الرابط تلقائيا فى النموذج المخصص لذلك او من خلال زر امر مرفق القاعدة نسخة 2003 و نسخة 2010 حتى تستطيع تشغيله على كمبيوتر الخاص بك على اى اصدار وبرنامج الماسج المذكور بارك الله فيك Archives2003-2010.rar WinScan2PDF.rar

الف شكر على هذه المجموعة الرائعة وجزاك الله خير

جزاك الله خيرا ووالدك أيضا نريد المزيد

شوفولي هالبرنامج و إدعولي وما بدي أذكركم هاي برامج مجمعة من مواقع ومنتديات ، يعني مش أنا إلي عاملها وبشكر أصحاب هذه البرامج لأنها راح تكون مفيدة للجميع إنشاء الله wzbackup.zip

جزاك الله كل خير وغفر لنا ولك ولوالدينا اجعين

وهنا برامج أخرى ،،،،، لا تنسونا بالدعاء زي ما وصيتكم ، ، ، accarch179.zip accarch171.zip