الـعيدروس

السلام عليكم جرب الكود التالي على اساس الخلايا ثابته Sub ALIDROOS_CP() Dim A As Worksheet, B As Worksheet, C As Worksheet Set A = Sheets(2): Set B = Sheets(3): Set C = Sheets(4) A.[G23].Copy: [F4].PasteSpecial xlPasteValues: B.[G23].Copy: [F9].PasteSpecial xlPasteValues: C.[G23].Copy: [F14].PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم الاخ الفاضل العام الجديد2012 عندي لايوجد أي مشكلة بيعمل 100% ربما الملف الذي تعمل عليه يختلف عن المرفق في المشاركة والسلام عليكم

السلام عليكم الاخ الفاضل samycalls ربما بطيئ عندك بسبب المعادلات جرب المرفق تقسيط السلع_ALI.rar

السلام عليكم إستخدم دالة vbnewline لعمل سطر جديد وايضا دالة vbcrlf تأدي نفس عمل الدالة السابقة مثال لإستخدام سطر جديد بدالة vbnewline Sub A_ali() S = "TOP" MsgBox "officena" & vbNewLine & S, vbInformation, "WELCOME" End Sub وهذا لإستخدام سطر جديد بدالة vbcrlf Sub B_ali() S = "TOP" MsgBox "officena" & vbCrLf & S, vbInformation, "WELCOME" End Sub وهكذا لمضاعفة المسافة كسطر جديد Sub C_ali() S = "TOP" MsgBox "officena" & vbCrLf & vbNewLine & S, vbInformation, "WELCOME" End Sub والسلام عليكم

السلام عليكم الاخ الفاضل رجب هذا حل بالاكواد عله يفي بالغرض جرب المرفق تحياتي تنسيق شرطى_A.rar

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

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

الاخ الفاضل نور سعيد فهم السؤال نصف الإجابه السموحه منك لم افهم طلبك ========================= ++++رابعأ كل هذأ بدابة من أولآ ينعكس وبكتب أونوماتيكيآ فى مسلسل الحركة أوتو نامبر مثل الآكسيس دون أن اكتبه انا "إقتباس" =========================

الاخ الفاضل نورسعيد لا شكرعلى واجب اضافة بسيطه للادخال الجديد جرب المرفق مندوب المبيعات_ALI_1.rar

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

السلام عليكم الف الف مبروك عليك الترقيه اخوي الشهابي الئ مزيد من التقدم

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

السلام عليكم Sub A_R_JC() Dim A As Range Dim E As Long Application.ScreenUpdating = False Dim X_ALI As XlCalculation X_ALI = Application.Calculation Application.Calculation = xlCalculationManual On Error GoTo C_ALIDROOS Const Z = "0.00" For Each A In ActiveSheet.Range("k6:k1005") If A.Value = Val(Z) Then A.Select A.EntireRow.Hidden = True End If Next A Application.Calculation = X_ALI Exit Sub C_ALIDROOS: Application.Calculation = X_ALI Application.ScreenUpdating = False End Sub

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

السلام عليكم الاخ الفاضل العام الجديد 2012 حفظك الله اولا ارجو منك التجربة الكاملة على الملف على حسب طلباتك وتوضيح جميع النقاط التي لم تتم بدلا من هدر الوقت والجهد والسموحه منك على هذا الخطاء ان شاء الله يكون زبط جرب المرفق المطلوب ترحيل _ALI_5.rar

جزاك الله خير اخي ابو الحسن على كلماتك الطيبه جرب هكذا Sub A_R_JC() Dim A As Range Dim E As Long Application.ScreenUpdating = False Dim X_ALI As XlCalculation X_ALI = Application.Calculation Application.Calculation = xlCalculationManual On Error GoTo C_ALIDROOS Const Z = "0.00" E = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row For Each A In ActiveSheet.Range("G2:G" & E) If A.Value = Val(Z) Then A.Select A.EntireRow.Hidden = True End If Next A Application.Calculation = X_ALI Exit Sub C_ALIDROOS: Application.Calculation = X_ALI Application.ScreenUpdating = False End Sub

السلام عليكم بعد اذن استاذي الحبيب عبدالله المجرب تعديل بسيط على الكود جرب هكذا للحالة الثانية Private Sub CommandButton2_Click() Application.ScreenUpdating = False w = 10 Do Until Cells(w, 1).Value = "" LR = Sheets("BDORDR").Range("A" & Rows.Count).End(xlUp).Row For i = 1 To 4 Cells(w, i).Copy Sheets("BDORDR").Cells(LR + 1, i).PasteSpecial xlPasteValues Sheets("BDORDR").Cells(LR + 1, i).Borders.Color = 2 Application.CutCopyMode = False Next w = w + 1 Loop Application.ScreenUpdating = True End Sub

السلام عليكم الاخ الحبيب ابو الحسن جرب هذا الكود Sub A_R_JC() Dim A As Range Dim E As Long Const Z = "0.00" E = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row For Each A In ActiveSheet.Range("G2:G" & E) If A.Value = Val(Z) Then A.Select A.EntireRow.Hidden = True End If Next A End Sub

السلام عليكم جرب المرفق واي تعديلات او اضافات انا موجود وعذراً على التأخير تعرف شواغل الدنيا المطلوب ترحيل _ALI_4.rar

اذا تكرمت حط كل بيانات ملف في شيت وشرح مبسط للمدى المراد ترحيل بياناته وارفق الملف وانا منتظر ردك

السلام عليكم تقصد ترحيل من ملف الى ملف وليس من شيت الى شيت ؟؟

بالنسبة للمدى تقدر تحط أي مدى تحب من هذا السطر If Not Intersect(Target, [E3]) Is Nothing Then مثلا لو المدى متفرق If Not Intersect(Target, [E3:E500,G3:G500,S3:S500]) Is Nothing Then واما قائمة التحقق حاولت ولم انجح اعذرني

ينفع كود حطه في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [E3]) Is Nothing Then If Target.Value > 40 And Not Target.Value = "غ" Then MsgBox "خطاء في الإدخال", vbCritical, "تنبية !!!" Target.Value = Empty Target.Select Exit Sub End If End If End Sub وهذا المرفق التحقق_ ALI.rar

Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim Z_ALI As Long With Feuil2.Range("A1").CurrentRegion Z_ALI = .Row + .Rows.Count [A1].Copy For E = 1 To 4 .Cells(Z_ALI, E) = Cells(E, 1) .Cells(Z_ALI, E).PasteSpecial xlPasteFormats Cells(E, 1).Value = Empty Next .Application.CutCopyMode = False End With Application.ScreenUpdating = True End Sub وهذا المرفق A_ALI_1.rar

السلام عليكم بعد اذن استاذي الحبيب احمد زمان جرب هكذا Private Sub CommandButton1_Click() On Error Resume Next Dim Z_ALI As Long With Feuil2.Range("A1").CurrentRegion Z_ALI = .Row + .Rows.Count For E = 1 To 4 .Cells(Z_ALI, E) = Cells(E, 1) Cells(E, 1).Value = Empty Next End With End Sub وهذا المرفق A_ALI.rar