الـعيدروس

الملف المرفق لم يعمل معي ماصيغتة ؟؟

السلام عليكم جرب المرفق D_ALI.rar

السلام عليكم جرب المرفق المطلوب ترحيل _ALI_3.rar

جزاك الله خير استاذ محمد صالح وبرضة هذا الكود تسجيل ماكرو Sub Macro1() Selection.AutoFilter End Sub

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

السلام عليكم الاخ الفاضل خالد القدس خلية التحكم بإسم الشيت A1 جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Excel.Range) Const S_N_ALI As String = "A1" Const S_ERR As String = "تسمية خاطئة " Dim S_NAM As String With Target If Not Intersect(.Cells, Range(S_N_ALI)) Is Nothing Then S_NAM = Range(S_N_ALI).Value If Not S_NAM = "" Then On Error Resume Next Me.Name = S_NAM On Error GoTo 0 If Not S_NAM = Me.Name Then MsgBox S_ERR & S_N_ALI End If End If End With End Sub وهذا المرفق CH_N_SH.rar

السلام عليكم وهذا برضه كود يقوم بعمل ارقام عشوائية بصندوق حوار للبداية والنهاية Sub Ashwai() Dim i As Integer, JX As Integer Dim a() As Long Dim ET_A As Boolean Dim XXX As Long, EX As Long, NU_A As Long On Error Resume Next Range(Cells(4, 4), Cells(Rows.Count, 4)).ClearContents XXX = Application.InputBox(prompt:="ادخل اول الارقام العشوائية" _ , Title:="تأليف أرقام عشوائية", Default:=1, Type:=1) EX = Application.InputBox(prompt:="ادخل الارقام النهائية العشوائية" _ , Title:="تأليف أرقام عشوائية", Default:=100, Type:=1) If EX = 0 Then Exit Sub If EX > 15000 Then EX = 15000 If EX > EX - XXX + 1 Then MsgBox "لايمكن تأليف سلسلة رقمية بداية اكبر من النهاية " _ & "ابداء برقم اصغر" Exit Sub End If ReDim a(EX) Randomize a(1) = Int((EX - XXX + 1) * Rnd + XXX) For i = 2 To EX Do NU_A = Int((EX - XXX + 1) * Rnd + XXX) ET_A = False For JX = 1 To i - 1 If NU_A = a(JX) Then ET_A = True: Exit For Next JX Loop While ET_A a(i) = NU_A Next i For i = 1 To EX Cells(i + 3, 4) = a(i) Next i End Sub وهذا المرفق AS_A.rar

السلام عليكم الاخ الفاضل sadouka نرجو طرح موضوع جديد لطلبك ولن يقصر لجميع معك الاخ الفاضل العام الجديد 2012 الشرط على ماذا مثلا ( الاسم - رقم القيد - تاريخ الميلاد ) نرجو التوضيح واما التعديل على الكل جرب المرفق والسلام عليكم المطلوب ترحيل _ALI_2.rar

الحمد لله شكرا لك وجزاك الله على كلماتك الرقيقة

حط التنسيق المراد في خلية M2 واستبدل الاكواد السابقة بهذه Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheets(CommandButton1.Caption) Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy With sh ALI = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Range("A" & ALI).PasteSpecial xlPasteValues Range("M2").Copy .Range(.Cells(ALI, 1), .Cells(ALI, 6)).PasteSpecial xlPasteFormats Application.CutCopyMode = False End With [E2:K3].ClearContents End Sub Private Sub CommandButton2_Click() Dim sh As Worksheet Set sh = Sheets(CommandButton2.Caption) Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy With sh ALI = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Range("A" & ALI).PasteSpecial xlPasteValues Range("M2").Copy .Range(.Cells(ALI, 1), .Cells(ALI, 6)).PasteSpecial xlPasteFormats Application.CutCopyMode = False End With [E2:K3].ClearContents End Sub

مثل ماذا تسطير مثلا ؟؟

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

هذا الكود للزر الاول Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheets(CommandButton1.Caption) Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy sh.Range("A" & sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues [E2:K3].ClearContents Application.CutCopyMode = False End Sub وهذا للزر الثاني Private Sub CommandButton2_Click() Dim sh As Worksheet Set sh = Sheets(CommandButton2.Caption) Union([A2], [C2], [E2], [G2], [I2], [K2]).Copy sh.Range("A" & sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues [E2:K3].ClearContents Application.CutCopyMode = False End Sub وهذا المرفق T_ALI.rar

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

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

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

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

استبدل كود زر الاضافة بهذا الكود Private Sub CommandButton1_Click() Dim sh As Worksheet Dim R As Integer, N As Integer, Endrow As Integer, ALI As Long Set sh = Sheets(TextBox4.Value) ALI = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 For R = 0 To 10 If Me.Controls(myCon(R)).Text = "" Then N = N + 1 Next If N <> 0 Then MsgBox "ملف فارغ لا يمكن الأضافة": GoTo 1 Me.MousePointer = 11 With Sheets("الكشف الرئيسي") Endrow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 For R = 0 To 10 .Cells(Endrow, R + 1).Value = Me.Controls(myCon(R)).Value If TextBox4.Value = sh.Name Then sh.Cells(ALI, R + 1).Value = Me.Controls(myCon(R)).Value End If Next R End With KH_A ActiveWorkbook.Save Me.MousePointer = 0 MsgBox "تمت الأضافة بنجاح" 1 End Sub وهذا المرفق المطلوب ترحيل _ALI_1.rar

السلام عليكم هذا الكود Sub ALIDROOS_JC_T() Application.ScreenUpdating = False Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets For R = 2 To 31 If sh.Name = "الكشف الرئيسي" Then GoTo 2 If Cells(R, 4).Value <> Empty Then If Cells(R, 4).Value = sh.Name Then Range(Cells(R, 1), Cells(R, 11)).Copy QQ = sh.Cells(1000, 1).End(xlUp).Row + 1 sh.Range("A" & QQ).PasteSpecial xlPasteValues End If End If Next 2 Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub وهذا المرفق المطلوب ترحيل _ALI.rar

السلام عليكم جرب هذا الكود Sub ALIDROOS_JC_F() Dim S_ALI$ Dim SAV_ALI As String SAV_ALI = Range("F7") & ":\" & Range("B7") & "\" S_ALI = Range("D7") & ".xls" If [B7].Value = "" Or [D7].Value = "" Or [F7].Value = "" Then MsgBox "قم أولاً بتسجيل إسم الملف وقرص الحفظ في الخلية المعنية", vbCritical, "_" Exit Sub Else: If MsgBox(" هل تريد حفظ البيانات في " & SAV_ALI & " بإسم " & S_ALI, vbQuestion + vbYesNo) = vbYes Then On Error Resume Next Application.DisplayAlerts = False GetAttr (SAV_ALI) Select Case Err.Number Case Is = 0 Application.DisplayAlerts = False ThisWorkbook.SaveCopyAs SAV_ALI & S_ALI Application.DisplayAlerts = True Case Else MkDir SAV_ALI ThisWorkbook.SaveCopyAs SAV_ALI & S_ALI End Select On Error GoTo 0 MsgBox "تم حفظ قاعدة بيانات بالأسم التالي..." & S_ALI & ALI_JC End If End If End Sub وهذا المرفق ALIDROOS_F.rar

السلام عليكم جرب المرفق به جزء من المطلوب والية كم صنف بإخال واحد اريد منك توضيح الالية كي يتم عمل المطلوب تحياتي المخزون_ALI.rar

السلام عليكم جرب هذا الكود Sub mSaveAs_ALI() Application.EnableEvents = False Application.DisplayAlerts = False ALI_JC = Range("F7") S_ALI = Sheet1.Range("D7") P_ALI = ALI_JC & ":\" If Sheet1.Range("D7").Value = "" Then MsgBox "قم أولاً بتسجيل إسم الملف في الخلية المعنية", vbCritical, "_" Exit Sub Else: If MsgBox(" هل تريد حفظ البيانات في " & P_ALI & " بإسم " & S_ALI, vbQuestion + vbYesNo) = vbYes Then ActiveWorkbook.SaveCopyAs Filename:=P_ALI & S_ALI & ".xls" MsgBox "تم حفظ قاعدة بيانات بالأسم التالي..." & S_ALI & ALI_JC End If End If Application.EnableEvents = True Application.DisplayAlerts = True End Sub

هذه الرسالة تظهر عندي في حال حصل خطاء في كود معين صارت معي كثير

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

استعن بهذا الكود Private Sub ComboBox1_Click() With ComboBox1 [B2].Value = .Value End With End Sub