مطلوب ترحيل من جدول الي جدول اخر بشكل مختلف

[أيهاب ممدوح]

الاخوة الافاضل 

مرفق ملف به الشرح

المصنف1.rar

[جمال عبد السميع]

تفضل أخى

تقبل تحياتى

ترحيل من جدول لجدول.rar

[أيهاب ممدوح]

اخي الكريم

عمل رائع لكن المشكله انه الملف يتغير بياناته كل شهر ومع المعادلات سوف يقوم بحساب البيانات مع الشهر فقط

لكن هذا الكشف تراكمي بيانات لشهر يناير وفبراير ...

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

لذلك اريدها كود للترحيل (نسخ و لاصق) بعد اخر سطر

ويوجد مشكله ان المعادلات لم تتعامل مع التاريخ والبيان

شكرا

[الصـقر]

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

بعد تعبئة البيانات اضغط على الزر

تقبل منى الاحترام والتقدير

المصنف1.zip

[أيهاب ممدوح]

اخي الكريم حسام

المطلوب نقل البيان والتاريخ  والمبلغ في عمود الشريك 

دون مسح البيانات الاصليه

شكرا

[الصـقر]

استاذى جرب المرفق لا يتم حذف البيانات الاصليه

المصنف1.zip

[أيهاب ممدوح]

شكرا جزيلا

لكن يوجد بعض النقاط عايز افهمها لو امكن

[أيهاب ممدوح]

اخي حسام عيسي

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

المشكله الثانيه وهي لو الشريك اسمه غير موجود يقوم باضافه صف فارغ في الكشف

شكرا

[أيهاب ممدوح]

تم حل المشكله الثانيه

باضافه Else الي الكود

Sub ßÔÝ_ÍÓÇÈ()
Dim mo As String

Dim Lr As Long, i As Long, Ln As Long, Lo As Long
Dim r As Integer
mo = Range("d10").Value
mn = Range("e10").Value
MM = Range("f10").Value

Application.ScreenUpdating = False
With ActiveSheet
    Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
   For i = 2 To 6
       If mo = CStr(.Cells(i, "f")) Then
       Cells(Lr + 1, "a").Value = .Cells(i, "a").Value
      Cells(Lr + 1, "b").Value = .Cells(i, "e").Value
        Cells(Lr + 1, "d").Value = .Cells(i, "b").Value
Else
End If
       If mn = CStr(.Cells(i, "f")) Then
       Cells(Lr + 2, "a").Value = .Cells(i, "a").Value
      Cells(Lr + 2, "b").Value = .Cells(i, "e").Value
        Cells(Lr + 2, "e").Value = .Cells(i, "b").Value
Else
End If
       If MM = CStr(.Cells(i, "f")) Then
       Cells(Lr + 3, "a").Value = .Cells(i, "a").Value
      Cells(Lr + 3, "b").Value = .Cells(i, "e").Value
        Cells(Lr + 3, "f").Value = .Cells(i, "b").Value
Else
End If

Next
End With
End Sub
      
        

[أيهاب ممدوح]

لم يحل 

[أيهاب ممدوح]

تم الحل في موضوع اخر قديم

http://www.officena.net/ib/index.php?showtopic=57218

شكرا استاذ حسام عيسي 

ومازلت في معك في موضوع العتاب للجميع

شكرا لكم جميعا

[أيهاب ممدوح]

Sub btnTransfer()
Dim i As Integer
Dim j As Integer
Dim LR As Integer

Dim SKey As String
Dim DKey As String

Dim Found As Boolean

For i = 2 To 6
    If Val(Range("B" & i)) <> 0 Then
    
        SKey = Range("A" & i) & Range("E" & i)
        LR = [A10000].End(xlUp).Row
        
        If LR < 11 Then LR = 10
        
        Found = False
        
        For j = 11 To LR
            DKey = Range("A" & j) & Range("B" & j)
            If SKey = DKey Then
                Select Case Range("F" & i)
                
                Case [D10]
                   Range("D" & j) = Val(Range("D" & j)) + Val(Range("B" & i))
                Case [E10]
                   Range("E" & j) = Val(Range("E" & j)) + Val(Range("B" & i))
                Case [F10]
                   Range("F" & j) = Val(Range("F" & j)) + Val(Range("B" & i))
            
                End Select
                
                Found = True
                Exit For
            End If
        Next j
        
       If Not Found Then
            Range("A" & LR + 1) = Range("A" & i)
            Range("B" & LR + 1) = Range("E" & i)
            
            Select Case Range("F" & i)
                
                Case [D10]
                   Range("D" & LR + 1) = Val(Range("B" & i))
                Case [E10]
                   Range("E" & LR + 1) = Val(Range("B" & i))
                Case [F10]
                   Range("F" & LR + 1) = Val(Range("B" & i))
            
                End Select
            
       End If
        
    End If
Next i
End Sub