omar elhosseini

خطأ بسيط في التنيسق ( Add_Borders )
تم علاجة
 
المرفقات
 
 
Test_3.xls

شاهد المرفق
 
راجع قيم التكست بوكس الأربع
للتأكد من صحة المعالجة
 
Test_1.rar

تفضل اخي
 
 
 
Cel to end data.xls

شاهد المرفقات
 
 
 
Test_1.xls

الأخ hesham monzer1
ضع اسم الشيت المراد حفظها في اول سطر من الكود بدلا من ( ورقة1 )
 
 
Const Sh_Name = "ورقة1" Sub finish() ' Dim FileExtStr As String Dim FileFormatNum As Long Dim xWs As Worksheet Dim xWb As Workbook Dim FolderName As String Application.ScreenUpdating = False Set xWb = Application.ThisWorkbook DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") FolderName = xWb.Path & "\" & xWb.Name & " " & DateString MkDir FolderName For Each xWs In xWb.Worksheets If xWs.Name = Sh_Name Then xWs.Copy If Val(Application.Version) < 12 Then FileExtStr = ".xls": FileFormatNum = -4143 Else Select Case xWb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If Application.ActiveWorkbook.HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum Application.ActiveWorkbook.Close False End If Next MsgBox "You can find the files in " & FolderName Application.ScreenUpdating = True ' End Sub  

شاهد المرفقات
 
 
 
Test_3.xls

الأخ عبدالله نبها
 
شاهد المرفقات
 
 
Test_1.rar

الملف بالمسار الخاص بك
 
 
 
Test_21.xls

تم التعديل
 
المرفقات
 
 
Test_2.rar

الاخ bachiri401
كيف
لا اخي هو يمنع اللصق تماما
راجع الملف الاول  ثم اخبرني من فضلك
 
علي العموم شاهد المرفق
تم منع اللصق عند عدم تطابق القيم مع قيم القائمة المنسدلة
 
 
 
Test_2.xlsm

الاخ ميلاد طارق
يجب اختيار الرقم من القائمة في الخلية( N1 )
شاهد المرفق
 
 
 
Test_1.xls

طلب الاخ ميلاد طارق
في موضوع
عمل زر متحرك
 
طلب تطبيق الكود للتثبيت في حال وجود اكثر من شكل في نفس الصفحه كما في المرفق حتى اقوم بتثبيت الاشكال في باقي الشيتات
 
وقد تم عمل اللازم
المرفق
 
 
 
 
Test_2.xls

اعد التحميل
الملف الاول 
تم استخدام عناصر تحكم النموذج بدلا من استخدام  عناصر تحكم  ActiveX
الملف الثاني
لم ينم الانشاء من عناصر تحكم النموذج او عناصر تحكم  ActiveX
بل تم انشاء الفرام والزر بأستخدام   Crate Object.Controls عن طريق انشائهم بواسطة  Module وبمساعدة  Class
كود Module1
Dim objButtons(1 To 1) As New Class1 Sub Add_Frame() With ActiveSheet.OLEObjects .Delete With .Add(ClassType:="Forms.Frame.1", Link:=False, DisplayAsIcon:=False) .Name = "Frame1" .Left = 400 .Top = 75 .Width = 200 .Height = 75 With .Object.Controls.Add("Forms.CommandButton.1", "cmdButton1", True) .Caption = "OK" .Left = 5 .Top = 5 .Width = 75 .Height = 30 End With End With End With Application.OnTime Now, "SetOnAction" ' End Sub Private Sub SetOnAction() ' Dim x As Control For Each x In ActiveSheet.OLEObjects(1).Object.Controls If TypeOf x Is MSForms.CommandButton Then i = i + 1 Set objButtons(i).CmdBtn = x End If Next On Error Resume Next If ActiveWorkbook.Sheets.Count = 1 Then Application.DisplayAlerts = False ActiveWorkbook.Sheets.Add.Delete Application.DisplayAlerts = True Else With ActiveSheet .Next.Activate .Activate End With End If ' End Sub  
كود Class1
Public WithEvents CmdBtn As MSForms.CommandButton Private Sub CmdBtn_Click() ' Select Case Me.CmdBtn.Caption Case "Ok" Case Else MsgBox "Hello" End Select ' End Sub مع استخدام حدث Workbook_Open
لعمل اضافة الفرام والزر عند فتح الملف
ولا توجد طريقة لأستخدام Frame سوي هاتين الططريقتين
Private Sub Workbook_Open() ' Add_Frame ' End Sub ومن الاسهل لك لتطويع الكود الطريقة الاولي بملف  Test_1
 
 
 
Test_1.xlsb Test_2.xlsb

الاخ smfsho2009
 
شاهد المرفق
 
 
 
Test_1.xls

استبدل هذا السطر
image_path = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False)  

تم علاج المشكلة
كنت بدأت العمل علي ذلك لأني توقعت سؤالك عن ذلك
في المساء ان شاء الله
شاهد المرفق
 
!_example_32.rar

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

الاخ Mahmoud Atef
بخصوص هذا الطلب :
 
من الصعب جدا عمل ذلك لأن القوائم المنسدلة تحتوي علي خلايا مدمجة
ماتم تنفيذه
1- جميع امدية القوائم اصبحت دياميكية
اي عند اضافة اي بنود جديدة لأي قائمة سوف تظهر بها
ولذلك تم استبدال المسافة بين اسماء الشتات بالشرطة السفلية ( _ )
2 -زر الطباعة يقوم بالمعاينة قبل تنفيذ امر الطباعة
3 - تم تعديل امر ( Save ) ليكون اتجاه الشيت في سياق الملف من اليسار الي اليمين 
اما بخصوص هذا الطلب 
صحح لي فهمي لهذا الطلب
سيتم وضع صورتين في الجزئين المدمجين وتتم طباعتهم في صفحة تالية للشكوي عند اختيار امر ( Attach )
 
شاهد المرفق
 
 
Complaints_new edit_2.rar

الاخ sam_farh
جرب هذا المرفق
 
مع ملاحظة ان :
البرنامج يعمل في بيئة وندوز 32 بت
و لا يعمل في بيئة وندوز 64 بت
 
 
!_Auto HD Serial Number.rar

بعد أذن اخي احمد بدره
الاخ السيد المصري
 
شاهد المرفق
 
 
 
Test_1.rar

تم التعديل
 
 
Test_2.rar

الاخ best smile
ربما يفي المرفق بالمطلوب
 
 
 
Test_1.xlsm

الاخ Zaher Rich
 
شاهد المرفق
 
 
Test_1.rar

الاخ roross
 
شاهد المرفقات
 
 
 
Test_1.xlsm

الاخ M.NHAKAMI
جرب هذا الكود
و انظرالمرفقات
Private Sub UserForm_Activate() ' With Application .WindowState = xlMaximized Zoom = Int(.Width / Me.Width * 100) Width = .Width Height = .Height End With ' End Sub Test_1.rar