a.kawkab

بداية طيبة بالتوفيق

إنا لله وإنا اليه راجعون البقاء لله ... اللهم اغفر لها وارحمها وأدخلها جنات الفردوس الأعلى , وألهم اهلها الصبر والسلوان

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

فعلا الكود شغال وبيعمل جيدا

بعد اذن الاساتذة اليك المطلوب ترحيل.xlsm

لغلق الملف الخارجي ( touati1 ) اضف هذا السطر فى نهاية الكود Windows("touati1.xlsx").close

للأسف ليس هذا المطلوب هذا المسار يتطلب تغييره تبعا للجهاز اللى هاتشتغل عليه / التعديل المطلوب ان يكون فى نفس المسار مثل ThisWorkbook.Path & "Output", FileFormat:=51= بحيث يعمل على اى جهاز فى اى مكان دون تعديل

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

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays() Dim ws As Worksheet Dim sSheets() As String Dim n As Long Application.ScreenUpdating = False For Each ws In Worksheets(Array("انسولين الهيئة", "انسولين الطلاب والرضع", "تقارير الاصناف")) n = n + 1 ReDim Preserve sSheets(1 To n) sSheets(n) = ws.Name Next ws Worksheets(sSheets).Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51 Application.DisplayAlerts = True ' ' For Each ws In ActiveWorkbook.Worksheets ' ws.UsedRange.Value = ws.UsedRange.Value ' Next ws For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws ActiveWorkbook.Close True Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub تم تعديلالكود بواسطة الاستاذ ياسر خليل جزاه الله خيرا وتم المطلوب والحمد لله وهذا الجزء هو ماتم تعديله For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws

ارجو من الاساتذة الافاضل ان يكون لدى احدهم حل للمطلوب التقارير.xlsm

بعد اذن الاستاذ سليم جرب هذه المعادلة فى الخلية f5 ثم اسجب نزولا لاسفل =F$4-D5

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays() Dim ws As Worksheet Dim sSheets() As String Dim n As Long Application.ScreenUpdating = False For Each ws In Worksheets(Array("تقاريرانسولين الهيئة", "تقارير انسولين الطلاب والرضع", "تقارير الاصناف")) n = n + 1 ReDim Preserve sSheets(1 To n) sSheets(n) = ws.Name Next ws Worksheets(sSheets).Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51 Application.DisplayAlerts = True For Each ws In ActiveWorkbook.Worksheets ws.UsedRange.Value = ws.UsedRange.Value Next ws ActiveWorkbook.Close True Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub الكود السابق يقوم بتصدير الشيتات المحددة الى شيت منفصل بدون اظهار المعادلات لكن عندما اقوم بحماية شيتات التقارير يرفض التصدير الا فى حالتين الاولى ان الغى الحمايه وهى ضروريهلعدم العبث فى المعادلات وبالتالى يحدث احطاء فى التفارير الثانية تعطيل الجزء ws.UsedRange.Value = ws.UsedRange.Value من الماكرو وفى هذه الحالة يتم تصدير التقارير مع المعادلات والمطلوب التصدير بدون معادلات اى قيم فقط مرفق صور توضيحية للمشكلة بالاضافة لملف العمل وكود الغاء الحماية123 التقارير.xlsm

اساتذة المنتدى الكرام مطلوب تعديل الكود التالى بحيت يتم تصدير البيانات بدون معادلات Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays() Dim ws As Worksheet Dim sSheets() As String Dim n As Long Application.ScreenUpdating = False For Each ws In Worksheets(Array("تقارير الانسولين", "تقرير الأصناف", "تقارير التكلفة" _ , "تقارير الريبافيرين والms", "هرمون النمو والثلاثيميا", "التذاكر الطبية")) n = n + 1 ReDim Preserve sSheets(1 To n) sSheets(n) = ws.Name Next ws Worksheets(sSheets).Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51 Application.DisplayAlerts = True For Each ws In ActiveWorkbook.Worksheets ws.UsedRange.Value = ws.UsedRange.Value Next ws ActiveWorkbook.Close True Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub

االسلام عليكم اليك هذا الملف لعله يفى بالغرض ترحيل واستدعاء.xlsm

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

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

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

مطلوب اختصار الكود التالى Private Sub CommandButton1_Click() Application.ScreenUpdating = False Application.Visible = True Sheets("الانسولين").Activate '============================================== Dim i As Integer, j As Integer lrow = Range("c" & Rows.Count).End(xlUp).Row + 1 If lrow < 5 Then lrow = 5 If lrow > 27 Then MsgBox "انتقل للبيان التالى": GoTo 1 ' Range("c" & lrow).Value = lrow - 5 With Sheets("الانسولين") .Range("C5:J1000").Select Selection.ClearContents .Range("c" & lrow).Offset(0, 0).Value = TextBox1 .Range("c" & lrow).Offset(0, 1).Value = TextBox2 .Range("c" & lrow).Offset(0, 2).Value = TextBox3 .Range("c" & lrow).Offset(0, 3).Value = TextBox4 .Range("c" & lrow).Offset(0, 4).Value = TextBox5 .Range("c" & lrow).Offset(0, 5).Value = TextBox6 .Range("c" & lrow).Offset(0, 6).Value = TextBox7 .Range("c" & lrow).Offset(0, 7).Value = TextBox8 .Range("c" & lrow).Offset(1, 0).Value = TextBox9 .Range("c" & lrow).Offset(1, 1).Value = TextBox10 .Range("c" & lrow).Offset(1, 2).Value = TextBox11 .Range("c" & lrow).Offset(1, 3).Value = TextBox12 .Range("c" & lrow).Offset(1, 4).Value = TextBox13 .Range("c" & lrow).Offset(1, 5).Value = TextBox14 .Range("c" & lrow).Offset(1, 6).Value = TextBox15 .Range("c" & lrow).Offset(1, 7).Value = TextBox16 .Range("c" & lrow).Offset(2, 0).Value = TextBox17 .Range("c" & lrow).Offset(2, 1).Value = TextBox18 .Range("c" & lrow).Offset(2, 2).Value = TextBox19 .Range("c" & lrow).Offset(2, 3).Value = TextBox20 .Range("c" & lrow).Offset(2, 4).Value = TextBox21 .Range("c" & lrow).Offset(2, 5).Value = TextBox22 .Range("c" & lrow).Offset(2, 6).Value = TextBox23 .Range("c" & lrow).Offset(2, 7).Value = TextBox24 .Range("c" & lrow).Offset(3, 0).Value = TextBox25 .Range("c" & lrow).Offset(3, 1).Value = TextBox26 .Range("c" & lrow).Offset(3, 2).Value = TextBox27 .Range("c" & lrow).Offset(3, 3).Value = TextBox28 .Range("c" & lrow).Offset(3, 4).Value = TextBox29 .Range("c" & lrow).Offset(3, 5).Value = TextBox30 .Range("c" & lrow).Offset(3, 6).Value = TextBox31 .Range("c" & lrow).Offset(3, 7).Value = TextBox32 1: ' .TextBox1.SetFocus ThisWorkbook.Save End With Application.Visible = False Application.ScreenUpdating = True End Sub فى الملف المرفق فورم به 140 تكست مطلوب كود مختصر لترحيل البيانات من ال140 تكست للشيت الانسولين.xlsm

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

اخى الكريم بتنسيق أعمدة الليست بوكس وحده واحدة اما الى اليسار او اليمين او الوسط لاينفع تنسيق كل عمود لوحده ولكن يمكنك التحكم فى عرض كل عمود حسب البيانات مثلا يكون عرض الاعمدة 50,70,90 وهكذا هذا لحد علمى ولكم الشكر

امساكية شهر رمضان 1441هـ 2020 م القاهرة - مصر ( فى رحاب الصحابة) ملف اكسل vba تفضل تم رفعه مباشرة على ميديا فاير ... لأن هذا افضل وأسهل بكثير إمساكية رمضان 1441 هـ

للاسف أستاذ عمر لايعمل على ويندوز 64

السلام عليكم اخى الكريم المشكل ليس فى الفورم كثرة المعادلات المستخدمه هى سبب البطئ لقد ممرت بهذة المشكلة فى ملف لدى وعندما استغنيت عن المعادلات واستخدمت الاكواد انتهت المشكلة لذلك ارى ان الحل واحد من اثنين 1- ان تستغنى عن الفورم وتصمم نموذج على شيت الاكسل وتستخدم المعادلات والاكواد فى ادخال البيانات 2- ان تغتمد على الفورم والاكوادلذلك حاول ان تجد اكواد بديلة للمعادلات واجعل المعادلات المستخدمة فى اقل الحدود

اعضاء المنتدى الكرام السلام عليكم تم والحمد لله حل المشكلتين (1) و(3)وتبقت المشكلة الثانية الخاصة بتثبيت رؤؤس الاعمدة فى الليست بوكس مرفق الملف بعد التعديل الخاصية Column Heads إلى True كانت مفعلة بالفغل وقد تم تدارك الخطا وهو ان رؤوس اغمدة البيانات كانت ضمن مدى rowsorce الليست بوكس لذلك كانت تتحرك مع البيانات وبعد ضبط مدىrowsorce الليست تم المطلوب وشكرا لكم A.k.2020_08-01-2020.xlsm