ياسر خليل أبو البراء

جرب الكود بهذا الشكل Private Sub CommandButton1_Click() DataEntry End Sub Private Sub CommandButton2_Click() End End Sub Private Sub UserForm_Activate() TextBox2.SetFocus End Sub Sub DataEntry() Dim TotalRows As Long Dim sh As Worksheet Set sh = ورقة1 If TextBox2.Text = "" Then MsgBox ("الرجاء ادخال اسم المادة") Exit Sub ElseIf TextBox3.Text = "" Then MsgBox ("الرجاء ادخال الكمية") Exit Sub ElseIf TextBox8.Text = "" Then MsgBox ("الرجاء ادخال سعر المادة") Exit Sub End If With sh TotalRows = .Cells(31, "C").End(xlUp).Row If TotalRows < 15 Then TotalRows = 15 Else TotalRows = TotalRows End If .Cells(TotalRows + 1, 3) = Me.TextBox2.Value .Cells(TotalRows + 1, 4) = Me.TextBox3.Value .Cells(TotalRows + 1, 5) = Me.TextBox8.Value .Cells(TotalRows + 1, 6) = Me.TextBox9.Value End With Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" Me.TextBox2.SetFocus End Sub

أمر آخر هل جربت وضع أي سيريال نمبر ؟؟؟ البرنامج يفتح حتى لو وضعت أي سيريال نمبر

أخي الحبيب ياسر العربي بارك الله فيك وجزاك الله خيراً على الموضوع الرائع نسيت تذكر أن يقوم المستخدم بنسخ الملف dll إلى مسار الويندوز مجلد System32 طيب خد أبسط حاجة :: افتح برنامج الإكسيل Ctrl + O اختصار أمر Open لفتح الملفات حدد الملف الخاص بك والمسمى DiskSerial.xlsm ومن لوحة المفاتيح اضغط Shift مع الاستمرار بس خلاص الملف تم فتحه بدون اللجوء إلى معرفة سيريال الهارد ديسك

أخي الكريم جرح العراقي يرجى فيما بعد وضع عنوان مناسب للموضوع ..يمكنك التعديل لعنوان ملائم ..مثلاً (تحويل ملف إكسيل إلى ملف فوكس برو DBF) عموماً قم بعملية بحث مطورة وتحصلت على كود يؤدي الغرض إن شاء الله كما أنه توجد برامج تقوم بهذه المهمة إليك الكود التالي ..لاحظ أن هناك بعض المكتبات يجب إضافتها ليعمل الكود المكتبات موجودة في بداية الكود ، وتكون الإضافة عن طريق Tools ثم References جرب الكود .. 'References: '*********** 'Microsoft ActiveX Data Objects Library 'Microsoft ADO Ext. 6.0 for DDL and security 'Microsoft Scripting Runtime '-------------------------------------------- Sub ExportToDBF() Dim FileName As Variant Dim Temp As Variant Dim CurrentFile As String Dim DefaultFile As String Dim sPath As String sPath = ThisWorkbook.Path CurrentFile = ActiveWorkbook.Name Temp = Split(CurrentFile, ".") Temp(UBound(Temp)) = "dbf" DefaultFile = Join(Temp, ".") If DefaultFile = "dbf" Then DefaultFile = ActiveWorkbook.Name & ".dbf" End If FileName = sPath & "\" & DefaultFile If FileName = False Then Exit Sub Call DoSaveDefault(FileName) End Sub Function DoSaveDefault(ByVal FileName As String) Dim Path As Variant Dim File As Variant Dim Tfile As Variant Dim Table As Variant Dim dbConn As ADODB.Connection Path = Split(FileName, "\") File = Path(UBound(Path)) File = Replace(Left(File, Len(File) - 4), ".", "_") & Right(File, 4) Tfile = "__T_DB__.dbf" Path(UBound(Path)) = "" Path = Join(Path, "\") Table = Left(Tfile, 8) FileName = Path & File On Error Resume Next GetAttr FileName If Err.Number = 0 Then Dim mbResult As VbMsgBoxResult mbResult = MsgBox("The file " & File & " already exists. Do you want to replace the existing file?", _ VbMsgBoxStyle.vbYesNo + VbMsgBoxStyle.vbExclamation, "File Exists") If mbResult = vbNo Then DoSaveDefault = False Exit Function Else SetAttr FileName, vbNormal Kill FileName End If End If Err.Number = 0 GetAttr FileName If Err.Number = 0 Then MsgBox "Unable to remove existing file " & File & ".", vbExclamation, "Error Removing File" DoSaveDefault = False Exit Function End If On Error GoTo 0 Set dbConn = New ADODB.Connection dbConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Path & ";Extended Properties=""DBASE IV;"";" Dim DataRange As Range Set DataRange = Selection If DataRange.Areas.Count > 1 Then MsgBox "The command you chose cannot be performed with multiple selections. Select a single range and click the command again.", _ VbMsgBoxStyle.vbCritical, "Error Saving File" DoSaveDefault = False Exit Function End If If DataRange.Cells.Count = 1 Then Dim Row1 As Integer Dim RowN As Integer Dim Col1 As Integer Dim ColN As Integer Dim CellFirst As Range Dim CellLast As Range Row1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row Col1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column RowN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ColN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column Set CellFirst = ActiveSheet.Cells(Row1, Col1) Set CellLast = ActiveSheet.Cells(RowN, ColN) Set DataRange = ActiveSheet.Range(CellFirst.Address, CellLast.Address) End If Dim I As Long Dim J As Long Dim NumCols As Long Dim NumDataCols As Long Dim NumRows As Long Dim C As Range Dim CreateString As String Dim Fieldpos(), Fieldvals(), Fieldtypes(), Fieldnames(), Fieldactive() NumCols = DataRange.Columns.Count NumDataCols = 0 NumRows = DataRange.Rows.Count ReDim Fieldtypes(0 To NumCols - 1) ReDim Fieldnames(0 To NumCols - 1) ReDim Fieldactive(0 To NumCols - 1) I = 0 For Each C In DataRange.Rows(1).Columns If WorksheetFunction.CountA(C.EntireColumn) > 0 Then Fieldactive(I) = True NumDataCols = NumDataCols + 1 If VarType(C.Value) = vbString Then Fieldnames(I) = Left(Replace(C.Value, " ", "_"), 10) Else Fieldnames(I) = "N" & C.Column End If Else Fieldactive(I) = False End If I = I + 1 Next ReDim Fieldpos(0 To NumDataCols - 1) ReDim Fieldvals(0 To NumDataCols - 1) For I = 0 To NumDataCols - 1 Fieldpos(I) = I Next If DataRange.Rows.Count < 2 Then For I = 0 To NumCols - 1 If Fieldactive(I) Then Fieldtypes(I) = vbString End If Next Else I = 0 For Each C In DataRange.Rows(2).Columns If Fieldactive(I) Then Fieldtypes(I) = VarType(C.Value) End If I = I + 1 Next End If Dim Cat As ADOX.Catalog Dim Tbl As ADOX.Table Dim Col As ADOX.Column Set Cat = New ADOX.Catalog Cat.ActiveConnection = dbConn Set Tbl = New ADOX.Table Tbl.Name = Table For I = 0 To NumCols - 1 If Fieldactive(I) Then Set Col = New ADOX.Column Col.Name = Fieldnames(I) FillColumnType Col, Fieldtypes(I), DataRange.Columns(I + 1) Tbl.Columns.Append Col Set Col = Nothing End If Next On Error Resume Next Cat.Tables.Delete Table On Error GoTo 0 Cat.Tables.Append Tbl Dim RS As ADODB.Recordset Dim R As Range Dim Row As Long Set RS = New ADODB.Recordset RS.Open Table, dbConn, adOpenDynamic, adLockPessimistic, adCmdTable If RS.LockType = LockTypeEnum.adLockReadOnly Then MsgBox "The recordset is read-only.", vbExclamation, "Error Inserting Record" End If For Row = 2 To NumRows Set R = DataRange.Rows(Row) If WorksheetFunction.CountA(R.EntireRow) > 0 Then I = 0 J = 0 For Each C In R.Cells If Fieldactive(I) Then Fieldvals(J) = GetValByVbType(C.Text, Fieldtypes(I)) J = J + 1 End If I = I + 1 Next RS.AddNew Fieldpos, Fieldvals End If Next RS.Close dbConn.Close Dim FS As Scripting.FileSystemObject Set FS = New Scripting.FileSystemObject FS.CopyFile Path & Tfile, FileName Set FS = Nothing Kill Path & Tfile DoSaveDefault = True End Function Function FillColumnType(Col As ADOX.Column, ByVal vtype As Integer, colrange As Range) As Boolean Dim GetAdoTypeFromVbType As Boolean Select Case vtype Case vbInteger, vbLong, vbByte Col.Type = adInteger Case vbSingle, vbDouble, vbDouble FillColNumberType Col, colrange Case vbCurrency Col.Type = adCurrency Case vbDate Col.Type = adDate Case vbBoolean Col.Type = adBoolean Case vbString FillColStringType Col, colrange Case Else Col.Type = adWChar Col.Precision = 32 End Select GetAdoTypeFromVbType = True End Function Function GetValByVbType(ByVal s As String, ByVal T As Long) Dim Result As Variant Result = Null On Error Resume Next Select Case T Case vbInteger, vbLong, vbByte Result = CInt(s) Case vbSingle, vbDouble, vbCurrency, vbDecimal If CInt(s) <> CDec(s) Then Result = CDec(s) Else Result = CInt(s) End If Case vbDate Result = CDate(s) Case vbBoolean Result = CInt(s) <> 0 Case vbString Result = s Case Else Result = Null End Select On Error GoTo 0 GetValByVbType = Result End Function Function FillColStringType(Col As ADOX.Column, R As Range) As Boolean Dim Lenshort As Long Dim Lenlong As Long Dim L As Long Dim C As Range Lenshort = Len(R.Cells(2).Text) Lenlong = Lenshort For Each C In R.Cells If C.Row > 1 Then L = Len(C.Text) If L < Lenshort Then Lenshort = L End If If L > Lenlong Then Lenlong = L End If End If Next If Lenlong > 254 Then Col.Type = adLongVarWChar ElseIf Lenlong > 128 And Lenlong < 255 Then Col.Type = adWChar Col.Precision = 254 ElseIf Lenshort = Lenlong And Lenlong < 17 Then Col.Type = adWChar Col.Precision = Lenlong Else Col.Type = adWChar Col.Precision = CeilPow2(Lenlong) End If FillColStringType = True End Function Function FillColNumberType(Col As ADOX.Column, R As Range) As Boolean Dim HasDecimal As Boolean Dim T As Boolean Dim C As Range HasDecimal = False On Error Resume Next For Each C In R.Cells If C.Row > 1 Then T = Val(C.Text) <> Int(Val(C.Text)) If Err.Number = 0 And T Then HasDecimal = True Exit For End If End If Next On Error GoTo 0 If HasDecimal Then Col.Type = adNumeric Col.Precision = 11 Col.NumericScale = 4 Else Col.Type = adInteger End If FillColNumberType = True End Function Function CeilPow2(x As Long) Dim I As Long I = 2 Do While I < x I = I * 2 Loop CeilPow2 = I End Function تقبل تحياتي

أخي الكريم إبراهيم يرجى اتباع التوجيهات ..راجع رابط التوجيهات في الموضوعات المثبتة في المنتدى للضرورة العنوان غير مناسب على الإطلاق بالنسبة لحل الأخ الكريم طلعت محمد حسن فهو حل صحيح طبقاً للمرفق الذي تفضلت به أما ما تذكره الآن يدل على أن الملف الأصلي مختلف عن الملف المرفق ..فيرجى إرفاق الملف الأصلي أو يكون الملف معبر عن الملف الأصلي تماماً لكي نتلافى حدوث أخطاء أرجو أن تتقبل كلامي بصدر رحب لأن ما أقوم به مجرد تنظيم للعمل كي يسهل على الأعضاء تقديم المساعدة بشكل أفضل تقبل تحياتي

أخي الكريم أناناس هل المقصود بـ Scale .. الخيار الموجود في إعداد الصفحة page Setup في التبويب المسمىPage باسم Scaling وتحته الخيار Adjust to ثم النسبة المئوية المطلوبة من الحجم الأصلي سؤال آخر: هل الخلايا ف النطاقين مدمجة كما في المرفق أم أن الدمج للتوضيح فقط لأنه يوجد مشكلة عند طباعة خلية واحدة فقط؟

أخي الكريم ارفق ملفك لتتضح المسألة أكثر ويساهم إخوانك بالحل

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

أخي الكريم جرب المرفق التالي فيه المثال الذي ذكرته عله يفي بالغرض Test.rar

بارك الله فيك أخي الحبيب ومعلمي الكبير مجدي يونس إن شاء الله تقدم أفضل مما فقد .. وقدر الله وما شاء فعل تقبل تحياتي

أنا أعمل على نظام الويندوز 10 64 بت والأوفيس أيضاً نسخة 2013 64 بت ..

رقم العمود AR هو الرقم 44 في الكود ..

أخي الحبيب العيدروس جربت ملفك ولكن على أوفيس 64 بت . قمت ببعض التغييرات في أسطر الإعلان حتى يتوافق مع نظام 64 بت ولكن يبدو أنه بحاجة إلى تعديلات أخرى بعد التعديلات الملف لا يعمل وتأتي رسالة إغلاق التطبيق .. هل من الممكن العمل على نظام 64 بت ؟؟

تسلم أخي الحبيب سليم على الإبداعات المتميزة بارك الله لنا فيك ولا حرمنا منك أبداً تقبل تحياتي

أعتذر إليك أخي الحبيب .. والله وقتي ضيق للغاية وإن شاء الله يتقدم أحد الأخوة الأعضاء بتقديم يد المساعدة تقبل تحياتي واعتذاري

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

لا حرمنا الله منك أخي الحبيب أسامة عمل متميز وفي قمة الروعة كروعة صاحبه تقبل وافر تقديري واحترامي

أخي الحبيب الغالي المتميز حسام عيسى ألف مبروك الترقية المستحقة عن جدارة ، وفي حقيقة الأمر لا أجيد استعمال الكلمات كأبي أبو يوسف ولكن رب كلمة تهنئة تكفيك ربما لا أكون أول المهنئين لك على الترقية ولكني أحسب نفسي أصدقهم وكما أخبرنا الحبيب أبو يوسف ...الترقية ليست مجرد ترفيع إنما هي في المقام الأول مسئولية ، وبإذن الله نحسبك أهلاً لها تقبل وافر تقديري واحترامي

أخي الكريم ناصر يفضل دائماً وضع الملف المرفق المعبر عن الملف الأصلي من البداية حتى لا يطول الموضوع بدون داعي كما يفضل أن يكون الطلب واضح تماماً مع توضيح تفاصيل الملف بالكامل .. لأن الأكواد حساسة جداً لكل تفصيلة عموماً إليك الكود التالي وإن شاء الله يفي بالغرض Sub Test() Dim Col As New Collection, Arr, I As Long, J As Long On Error Resume Next Arr = Sheet1.Range("A7:J" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row).Value For I = 2 To UBound(Arr, 1) For J = 2 To UBound(Arr, 2) Col.Add Key:=J & Chr(2) & Arr(I, 1), Item:=Arr(I, J) Next J Next I With Sheet2.Range("A7:J" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row) Arr = .Value For I = 2 To UBound(Arr, 1) For J = 2 To UBound(Arr, 2) Arr(I, J) = Col(J & Chr(2) & Arr(I, 1)) Next J Next I .Value = Arr End With End Sub أرجو أن يكون المطلوب إن شاء الله تقبل تحياتي

أخي الغالي العيدروس منور المنتدى بمشاركاتك الرائعة والمدهشة صراحة عمل رائع وفي منتهى الدقة ممكن بس أعرف فايدة الجزء دا في الكود Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) A = KeyCode: B = Shift If B <> 0 Then If B = 2 And A <> 17 Then Call SetControlFocus(A, B) End If End If End Sub لأني قمت بحذفه ولم يتأثر الملف ..أعتقد أنه زيادة أو لربما له غرض آخر .. ما الفائدة منه للاستفادة؟ وأين هو الإجراء المسمى SetControlFocus

بارك الله فيك أخي الحبيب ياسر العربي على الكود الجميل لكن كما ذكر الأخ السائل .. أنه في هذه الحالة سيكون هناك ارتباط بين المصنفين كما أن الكود طويل لأنه يحتوي على إلغاء خاصية اهتزاز الشاشة وإعادة تفعيلها ، وإلغاء خاصية التنبيه بالرسائل وإعادة تفعيلها .. وذلك لتجنب حدوث خطأ في حالة تنفيذ الكود مرة أخرى كما أنه يحتوي أسطر لنسخ أوراق العمل بالتنسيقات ثم نسخها مرة أخرى بالقيم فقط ..مما يحافظ على التنسيق الأصلي للملف وفي نفس الوقت يتم لصق القيم فقط لإلغاء الارتباط أخ السائل يمكنك تغيير اسم الظهور من خلال الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى من هنا لمعرفة التفاصيل بالنسبة لسؤالك غير السطر الثالث ليكون بهذا الشكل ArrSheetToCopy = Array(Sheet2.Name, Sheet3.Name)

إذا كنت تقصد أخي الحبيب علامة الإغلاق في الفورم فهذا أمر يسير يمكن استخدام الكود التالي في حدث الفورم Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = True MsgBox "تم إلغاء هذا الزر للإغلاق .. لطفاً استخدم زر الأمر", vbCritical End If End Sub إليك الملف المرفق Test YasserKhalil.rar

أخي الحبيب سليم بارك الله فيك على هذه الهدايا القيمة بالنسبة للكود فهو رائع حقاً ولكن هناك نقطة في غاية الأهمية ألا وهي البيانات إذا كانت كثيرة جداً ربما يواجه المستخدم مشكلة لنفترض أن لديك 200 رقم وسيتم تقسيمهم كل 3 في ورقة عمل ..أي أنه سيلزم للأمر 66 ورقة .. في الكود اعتمدت على تسمية أوراق العمل باسم List ثم حرف من الحروف ، والحروف 26 حرف فقط بالتالي سيحدث خطأ .. أمر آخر : أفضل وضع الأكواد في موديول .. يمكن تعديل الكود بهذا الشكل Sub CopyEveryN() Dim LR As Long, Y As Long, N As Long, X As Long, K As Long LR = Sheets(1).Cells(Rows.Count, 1).End(3).Row Y = 0 N = [C1] If Not IsNumeric(N) Or N <= 0 Then MsgBox "اكتب عدداً صحيحاً", 64: Exit Sub If N >= LR Then N = 1 End If N = Int(N) X = Sheets.Count Application.ScreenUpdating = False Application.DisplayAlerts = False Do While X > 1 Sheets(X).Delete X = X - 1 Loop For K = 0 To LR Step N Sheets(1).Range("A" & K + 1 & ":A" & K + N).Copy Sheets.Add After:=Sheets(Sheets.Count) With ActiveSheet .Name = "List" & Y + 1 .Range("A1").PasteSpecial xlValues .Columns(1).AutoFit .Range("A1").Select End With Y = Y + 1 Next Application.Goto Sheet1.Range("A1") Application.CutCopyMode = False Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub أخي الحبيب سليم حاول تراعي الإعلان عن المتغيرات .. تقبل وافر تقديري و تحياتي

الحمد لله أن تم المطلوب على خير يرجى تغيير اسم الظهور للغة العربية لمزيد من التفاصيل يمكنك الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى نتمنى لكم جميعاً ليلة طيبة مباركة وتصبحون على خير دمتم على طاعة الله

أخي الحبيب يرجى تغيير اسم الظهور للغة العربية إليك الكود التالي عله يفي بالغرض Sub ExportSpecificSheets() Dim ArrSheetToCopy, I As Long If MsgBox("هل تريد نسخ أوراق العمل المحددة إلى مصنف جديد؟", vbYesNo, "NewCopy") = vbNo Then Exit Sub ArrSheetToCopy = Array("التحويل", "المستبعدين") Application.ScreenUpdating = False Application.DisplayAlerts = False With Workbooks.Add For I = (.Sheets.Count + 1) To (UBound(ArrSheetToCopy) + 1) .Sheets.Add Next I For I = 0 To UBound(ArrSheetToCopy) ThisWorkbook.Sheets(ArrSheetToCopy(I)).Cells.Copy With .Sheets(I + 1) .Cells.PasteSpecial xlPasteAll .Cells.Copy .Cells.PasteSpecial xlPasteValues .Name = ThisWorkbook.Sheets(ArrSheetToCopy(I)).Name .DisplayRightToLeft = False .Select: .Range("A1").Select End With Next I .SaveAs ThisWorkbook.Path & "\" & Sheet2.Name & ".xlsm", xlOpenXMLWorkbookMacroEnabled .Close End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub إليك الملف المرفق عله يكون المطلوب تقبل تحياتي Test This File.rar