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

جزاك الله خيراً أخي محمد ننتظر لحين إتمام الأمر لربما يكون هناك تعديلات مطلوبة ، بعدها يمكن الشروع في شرح الكود إن شاء الله

وعليكم السلام Sub Test() Dim arr1 As Variant Dim arr2 As Variant Dim temp As Variant Dim varTemp1 As Variant Dim varTemp2 As Variant Dim i As Long Dim r As Long Dim x As Long arr1 = Range("B55:F234").Value arr2 = Range("H55:L234").Value ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 5) For i = LBound(arr1, 1) To UBound(arr1, 1) If Not IsEmpty(arr1(i, 2)) Then r = r + 1 temp(r, 1) = arr1(i, 1) temp(r, 2) = arr1(i, 2) temp(r, 5) = arr1(i, 5) End If Next i For i = LBound(arr2, 1) To UBound(arr2, 1) If Not IsEmpty(arr2(i, 2)) Then r = r + 1 temp(r, 1) = arr2(i, 1) temp(r, 2) = arr2(i, 2) temp(r, 5) = arr2(i, 5) End If Next i If r > 180 Then ReDim varTemp1(1 To 180, 1 To 5) For i = 1 To 34 varTemp1(i, 1) = temp(i, 1) varTemp1(i, 2) = temp(i, 2) varTemp1(i, 5) = temp(i, 5) Next i Range("O55").Resize(180, 5).Value = varTemp1 ReDim varTemp2(181 To UBound(temp, 1), 1 To 5) For i = 181 To UBound(temp, 1) varTemp2(i, 1) = temp(i, 1) varTemp2(i, 2) = temp(i, 2) varTemp2(i, 5) = temp(i, 5) Next i Range("U55").Resize(r - 180, 5).Value = varTemp2 Else Range("O55").Resize(r, 5).Value = temp End If End Sub

استبدل الفاصلة بفاصلة منقوطة (يرجع لإعدادات الويندوز لديك)

هل الملف المطلوب يفي بالغرض؟ 2020.rar

Sub Test() Dim arr As Variant Dim i As Variant Dim j As Long arr = Sheets("Sheet1").Range("A1").CurrentRegion.Value For Each i In Array(2, 7, 11) j = j + 1 Sheets("Sheet2").Cells(1, j).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) Next i End Sub

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

معادلة صفيف لإثراء الموضوع =IF(A1="","",SUM(VALUE(MID(TEXT(A1,"yyyymmdd"),ROW($A$1:OFFSET($A$1,LEN(TEXT(A1,"yyyymmdd"))-1,0)),1))))

وعليكم السلام ورحمة الله وبركاته الحمد لله الذي بنعمته تتم الصالحات ، والحمد لله أن تم المطلوب على خير أخي الكريم سيف الدين

السلام عليكم في الخلية A2 اكتبي المعادلة التالية ثم قومي بسحبها لأسفل =INDIRECT(ADDRESS(25,ROWS($A$1:A3)))

الأخت الكريمة الكود بسيط جداً وهو يعتمد على حلقة تكرارية من آخر صف للصف الثاني ، مع إدراج صف فارغ فقط في حالة إذا كانت الخلية لا تساوي فراغ حاولي دراسة الكود سطر سطر وإذا تعثرتي في أمرٍ ما فلتقومي بعمل مشاركة للسؤال عما استصعب عليكي Sub Insert_Blank_Row() 'تعريف متغير ليكون بمثابة عداد للحلقة التكرارية Dim i As Long 'سطر لإيقاف خاصية اهتزاز الشاشة لتسريع الكود Application.ScreenUpdating = False 'حلقة تكرارية من آخر صف للصف الثالث ولأن الحلقة معكوسة استخدمنا -1 For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 'إذا كانت الخلية في العمود الأول في الصف الهدف غير فارغة فإنه 'يتم إدراج خلايا لأسفل في النطاق المحدد من العمود الأول للثاني If Len(Trim(Cells(i, 1))) <> 0 Then Range(Cells(i, "A"), Cells(i, "B")).Insert Shift:=xlDown 'الانتقال للصف التالي Next i 'إعادة خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub مع التعديل في الكود الأصلي قليلاً

لاحظ في الملف المرفق الأخير عدم وجود مبالغ مع بعض الأسماء

Sub Test() Dim arr1 As Variant Dim arr2 As Variant Dim temp As Variant Dim varTemp1 As Variant Dim varTemp2 As Variant Dim i As Long Dim r As Long Dim x As Long arr1 = Range("B3:C36").Value arr2 = Range("E3:F36").Value ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 2) For i = LBound(arr1, 1) To UBound(arr1, 1) If Not IsEmpty(arr1(i, 1)) Then r = r + 1 temp(r, 1) = arr1(i, 1) temp(r, 2) = arr1(i, 2) End If Next i For i = LBound(arr2, 1) To UBound(arr2, 1) If Not IsEmpty(arr2(i, 1)) Then r = r + 1 temp(r, 1) = arr2(i, 1) temp(r, 2) = arr2(i, 2) End If Next i If r > 34 Then ReDim varTemp1(1 To 34, 1 To 2) For i = 1 To 34 varTemp1(i, 1) = temp(i, 1) varTemp1(i, 2) = temp(i, 2) Next i Range("J3").Resize(34, 2).Value = varTemp1 ReDim varTemp2(35 To UBound(temp, 1), 1 To 2) For i = 35 To UBound(temp, 1) varTemp2(i, 1) = temp(i, 1) varTemp2(i, 2) = temp(i, 2) Next i Range("M3").Resize(r - 34, 2).Value = varTemp2 Else Range("J3").Resize(r, 2).Value = temp End If End Sub

Sub Test() Dim arr1 As Variant Dim arr2 As Variant Dim temp As Variant Dim i As Long Dim r As Long arr1 = Range("B3:C36").Value arr2 = Range("E3:F36").Value ReDim temp(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 2) For i = LBound(arr1, 1) To UBound(arr1, 1) If Not IsEmpty(arr1(i, 1)) Then r = r + 1 temp(r, 1) = arr1(i, 1) temp(r, 2) = arr1(i, 2) End If Next i For i = LBound(arr2, 1) To UBound(arr2, 1) If Not IsEmpty(arr2(i, 1)) Then r = r + 1 temp(r, 1) = arr2(i, 1) temp(r, 2) = arr2(i, 2) End If Next i Range("J3").Resize(r, 2).Value = temp End Sub

وعليكم السلام Sub Test() Dim arr As Variant Dim temp As Variant Dim i As Long Dim r As Long arr = Range("B3:C36").Value ReDim temp(1 To UBound(arr, 1), 1 To 2) For i = LBound(arr, 1) To UBound(arr, 1) If Not IsEmpty(arr(i, 1)) Then r = r + 1 temp(r, 1) = arr(i, 1) temp(r, 2) = arr(i, 2) End If Next i Range("G3").Resize(r, 2).Value = temp End Sub

J3 =MOD(SUM(D3,H3)-F3,1000) K3 =(SUM(E3,I3)+QUOTIENT(SUM(D3,H3),1000))-(G3+QUOTIENT(F3,1000))

الكود صحيح ويعمل

وعليكم السلام

رابط المصدر وإليك الملف .. اضغط Alt + F8 وانقر على زر Run .. جرد المستودع 1-12-2016.rar

نضيف شرط لسطر الشرط الموجود باستخدام الدالة AND .. ادرس الكود بشكل جيد واقرأ الشرح بشكل جيد لكي تتعرف أكثر والأفضل التطبيق

السلام عليكم Transfer Data To Another Sheet By Formulas.rar

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

Sub Test() Dim cell As Range, rng As Range, oRange As Range Application.ScreenUpdating = False Set rng = Range("B1:B100") For Each cell In rng If cell.Value <> "agent '450'" Then If oRange Is Nothing Then Set oRange = cell Else Set oRange = Union(oRange, cell) End If Next cell If Not oRange Is Nothing Then oRange.EntireRow.Delete Application.ScreenUpdating = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then If Target.Value = 5 Then ActiveSheet.PrintOut End If End If End Sub