الـعيدروس

السلام عليكم لاادري ان كنت فهمت طلبك بالشكل الصحيح لاكن جرب هذا الكود عله ماتريد Sub Ali_Trn() Dim sh As Worksheet Dim S As Worksheet Dim rt As Range, Rn As Range Set sh = Feuil1 Set S = Feuil2 Dim Ar_1(), Ar_2() Dim CC, q, cx, AA Static D% Dim C%, TT%, I%, x% Dim QQ$ Dim REE As Variant Dim Z As String CC = S.Cells(Rows.Count, 1).End(xlUp).Row TT = 0: q = 0 For I = 1 To CC If CStr(Cells(I, 1)) <> Empty Then ReDim Preserve Ar_1(0 To C) Ar_1(C) = S.Cells(I, 1).Row FF = FF & "," & S.Cells(I, 1).Address(False, False) C = C + 1 D = D + 1 End If Next For Each rt In sh.Range("A2:C24") q = q + 1 If Val(q) = Val(D) + 1 Then Exit For If CStr(sh.Cells(rt.Row, rt.Column)) <> Empty Then ReDim Preserve Ar_2(0 To cx) Ar_2(cx) = "'" & sh.Name & "'" & "!" & rt.Address(False, False) QQ = Ar_2(cx) x = Ar_1(TT) S.Cells(x, 2) = Range(QQ) S.Cells(x, 2).Offset(0, -1).Resize(, 7).Borders.Color = RGB(0, 0, 0) cx = cx + 1 End If TT = TT + 1 Next With S Application.ScreenUpdating = False QW = .Cells(Rows.Count, 1).End(xlUp).Row For Each Rn In .Range(.Cells([A2].End(xlDown).Row, 1), .Cells([A1500].End(xlUp).Row, 1)) If Rn.Value = "" Then Rn.EntireRow.Hidden = True End If Next Application.ScreenUpdating = True ER = WorksheetFunction.CountA(.Range("A:B")) + 1 ZZ = "A9:G" & QW Z1 = "B9:G" & QW Debug.Print ZZ .PageSetup.PrintArea = ZZ .Range(ZZ).PrintPreview .UsedRange.EntireRow.Hidden = False .PageSetup.PrintArea = "" .Range(Z1) = "" End With D = 0 Erase Ar_1 Erase Ar_2 End Sub

السلام عليكم عدلت مسمى الاوراق حسب طلبك tt_1.rar

السلام عيكم Sub L_ali() Dim r As Range For Each r In Range("L6:L6500") If r - Int(r) > 0 And r.Value <> Empty Then r.Value = Ali_In(r.Value) End If Next End Sub Function Ali_In(Val_A As Double) As Double Dim ali As Long Dim adad As Double ali = Int(Val_A) adad = Val_A - ali If adad < 0.5 Then Ali_In = ali Else Ali_In = ali + 1 End If End Function

السلام عليكم تفضل جرب هذا الكود Sub Ali_Trn() Dim sh As Worksheet Dim S As Worksheet Dim r Set sh = ورقة1 Set S = ورقة2 c = 1 rc = sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row For r = 2 To 1000 If Not IsEmpty(S.Cells(r, 1)) Then sh.Cells(rc, c) = S.Cells(r, 1) c = c + 1 If c = 4 Then c = 1: rc = rc + 1 End If Next With sh .Select ER = WorksheetFunction.CountA(.Range("A:C")) + 1 Z = "A2:C" & ER .Range(Z).PrintPreview End With End Sub

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

ارفق مثال اخي وإن شاء الله يتم تلبية طلبك

السلام عليكم Private Sub CommandButton1_Click() Me.TextBox1 = Time End Sub

أي عمود أرصده الذي تقصده الذي ينطبق عليه الشرط كي يتم مسح الخلايا السابقة ذكرها من قبلك ؟؟

الاستاذ القدير دغيدي هكذا جمع الصفوف باليدوي أعتقد أنه مطابق لنتائج الكود ؟؟ ======================= جمع قيم الصفوف " 17:10" = 84 ======================= جمع قيم الصفوف " 25:18" = 148 ======================= جمع قيم الصفوف " 32:26" = 182 ======================= جمع قيم الصفوف " 17:10" = 84

السلام عليكم جرب المرفق إن شاء الله يفي بالغرض استخراج تقرير للموظف_A.rar

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

الاستاذ الحبيب دغيدي هذا تعديل الكود من قبلي لطلبك الاخير بداية صف الجمع حسب الرقم المدرج في "L2" Sub Su_Alidroos() On Error Resume Next A = [J2]: AA = [K2] B = [J3]: BB = [K3] Ct = [J4]: CC = [K4] D = [J5]: DD = [K5] '============================================= 'خلية تحدد فيها بداية رقم صف الجمع المراد RR = Val([L2]) '============================================= For C = 1 To 8 Cells(RR, C) = S_Ali(Range(Cells(A, C), Cells(AA, C))) Cells(RR + 1, C) = S_Ali(Range(Cells(B, C), Cells(BB, C))) Cells(RR + 2, C) = S_Ali(Range(Cells(Ct, C), Cells(CC, C))) Cells(RR + 3, C) = S_Ali(Range(Cells(D, C), Cells(DD, C))) Next End Sub Function S_Ali(m_r As Range) Dim C_Ali As Range, C_D As Double For Each C_Ali In m_r If IsNumeric(C_Ali) Then C_D = C_D + C_Ali.Value End If Next S_Ali = C_D End Function وبعد اذن الاستاذ القدير خوبر خير وهذا كود العلامه خوبر خير Sub kh_Sum() Dim RngTest As Range Dim R As Integer, C As Integer Dim RR1 As Integer, RR2 As Integer '============================================= 'خلية تحدد فيها بداية رقم صف الجمع المراد Kh_Add = [L2] '============================================= Set RngTest = Range("MySumRow") With Range("A4:H61") For R = 1 To RngTest.Rows.Count RR1 = RngTest.Cells(R, 1).Value RR2 = RngTest.Cells(R, 2).Value For C = 1 To .Columns.Count Range("A" & Kh_Add).Cells(R, C) = WorksheetFunction.Sum(Range(.Cells(RR1, C), .Cells(RR2, C))) Next Next End With Set RngTest = Nothing End Sub الجمع بمعلومية خلايا_1.rar

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

السلام عليكم جزاك الله خير استاذ عبدالله كنت توصلت لحل ولكنه بدائي جدا Sub Su_Alidroos() On Error Resume Next A = [J2]: AA = [K2] B = [J3]: BB = [K3] Ct = [J4]: CC = [K4] D = [J5]: DD = [K5] RR = Range("A4").CurrentRegion.Rows.Count + 1 For C = 1 To 8 Cells(RR, C) = S_Ali(Range(Cells(A, C), Cells(AA, C))) Cells(RR + 1, C) = S_Ali(Range(Cells(B, C), Cells(BB, C))) Cells(RR + 2, C) = S_Ali(Range(Cells(Ct, C), Cells(CC, C))) Cells(RR + 3, C) = S_Ali(Range(Cells(D, C), Cells(DD, C))) Next End Sub Function S_Ali(m_r As Range) Dim C_Ali As Range, C_D As Double For Each C_Ali In m_r If IsNumeric(C_Ali) Then C_D = C_D + C_Ali.Value End If Next S_Ali = C_D End Function

الاستاذ الحبيب دغيدي على أي أعمده ينطبق الجمع

عندي يظهر في الوسط ؟

لديك عمودين للارصده " C,i " أي عمود تقصد ؟

السلام عليكم الاخ الفاضل ahmd2505 عظم الله اجرك واحسن عزاك وإنا لله وانا اليه راجعون البقاء لله

السلام عليكم تفضل ترحيل فاتورة_A.rar

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

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

السلام عليكم ارفاق مثال وعليه شرح ماتريد ان شاء الله نتصول الى حل طلبك

السلام عليكم طلبك الثاني استبدل هذه الاكواد بكود زر الترحيل Private Sub Kh_E() On Error Resume Next Dim cotl As Control Dim LastRow As Long Dim Addrs As String '''''''''''''' LastRow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row + 1 '''''''''''''' For Each cotl In Me.FrameList.Controls If Len(Trim(cotl)) Then Addrs = cotl.Name Sheets("Data").Cells(LastRow, "A").Range(Addrs).Value = cotl.Value End If Next End Sub Private Sub CommandButton1_Click() On Error Resume Next Dim CO As MSForms.TextBox Dim AA% Dim MS As String For Each CO In Me.FrameList.Controls If CO.Value = "" Then MS = MS & AA AA = AA + 1 Else Kh_E End If Next MsgBox "يوجد " & " : " & Len(MS) & " ] " & " حقل فارغ لايمكن الترحيل اكمل تعبئة الحقول الفارغه" & " ] ", vbCritical End Sub

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

جربته الان شغال مزبوط بعد ضغط الزر يبقى السطر الافتراضي فقط ماهي المشكله التي تواجها ؟؟