مطلوب كود ترحيل

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

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

الشرح داخل الملفترحيل من جدول لجدول.rar

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

للرفع

[ابو تراب]

هلا ايهاب

 

جرب المرفق

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

تم تعديل ديسمبر 3, 2014 بواسطه ابو تراب

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

ررررررررررررررررررررررائع جداااااااااااااااااااااا

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

الشرح لو سمحت

[ابو تراب]

الفكرة انه لديك جدولين و تم الربط بينهما عن طريق مفتاح مركب (التاريخ و البيان) -- نفس فكرة جداول الأكسس composite primary key.

 

وقد تم تعريف متغيرين الاول Skey يمثل مفتاح الجدول الاول و Dkey يمثل مفتاح الجدول الثاني. 

 

اذا تطابق المفتحان يتم اختيار الشريك المناسب و تحديت البيانات.

 

في حالة لا يوجد تطابق للمفتاحين في اي سطر من اسطر الجدول الثاني يتم اضافة سطر جديد و تحديث البيانات.

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
اذا كان الجدول الثاني فارغا فأبد من الخلية رقم A11        
        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 iEnd Sub

تم تعديل ديسمبر 3, 2014 بواسطه ابو تراب

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

ما شاء الله شرح جميل بارك الله فيك يا اخي

تم تعديل ديسمبر 3, 2014 بواسطه ايهاب ممدوح

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

اخي الكريم 

لو حبيت ان الجدول الثاني يكون 30 صف وبجانبه نفس الجدول 30 صف 

وعند امتلاء الجدول الاول للمسحوبات يبدأ في الجدول الثاني للمسحوبات

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

[ابو تراب]

اخي ايهاب جرب المرفق

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

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

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

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

اخي الكريم

حاولت نقل الكود للملف الاصلي لكن للأسف ...

ممكن شرح الكود لو سمحت

[ابو تراب]

هلا ايهاب

 

الغرض من الكود هو اعطائك حرية تحديد اكثر من جدول لتعبئة البيانات على شرط ان كل جدول عدد صفوفه 30 صف.

 

والفكرة في تحقيق ذلك:

1- انشاء مصفوفة تضع فيها مدى الجداول...في الملف المرفق و ضعت مدى الجدولين:

Dim Tables() As String
Tables = Split("A11:F40,G11:L40", ",")

مدى الجدول الاول هو A11:F40 و الجدول الثاني هو G11:L40 (بالطبع يمكنك و ضع جدول ثالث و رابع على حسب الرغبة)

 

2- انشاء دالة ذات مرجع لنفسها او الدالة التي تستدعي نفسها Recursive function. مهمة هذه الدالة تعبئة الجدول. فاذا كان الجدول الاول ممتلئ و لا يوجد تطابق تستدعي الدالة  نفسها لتبحث في الجدول الثاني و هكذا الى ان تحدث الجدول.  في حالة جميع الجداول ممتلئة و لايوجد تطابق في اي سطر ترجع القيمة False دلالة على امتلاء جميع الجداول.

Public Function UpdateTable(ByRef Tables() As String, TableIndex As Integer, SKey As String, SIndex As Integer) As Boolean

Tables : يمثل مصفوفة الجداول

TableIndex : يمثل رقم الجدول. الرقم 0 يعني الجدول الاول و الرقم 1 يمثل الجدول الثاني و هكذا.

SKey: مفتاح المركب في جدول المصدر 

SIndex : يمثل رقم السطر في جدول المصدر 

Sub btnTransfer()
Dim Tables() As String
Tables = Split("A11:F40,G11:L40", ",")


Dim SKey As String
Dim Found As Boolean


Dim i As Integer




For i = 2 To 6
    If Val(Range("B" & i)) <> 0 Then
    
        SKey = Range("A" & i) & Range("E" & i)
        
        Found = UpdateTable(Tables, 0, SKey, i)
                
       If Not Found Then
            MsgBox "الجداول ممتلئة..لم يتم ترحيل من السطر رقم: " & i, vbCritical + vbOKOnly, "خطأ في الترحيل"
            Exit For
       End If
        
    End If
Next i
End Sub






Public Function UpdateTable(ByRef Tables() As String, TableIndex As Integer, SKey As String, SIndex As Integer) As Boolean
Dim Table As Range
Dim DKey As String
Dim LR As Integer


Dim j As Integer
Dim Found As Boolean


Set Table = Range(Tables(TableIndex))


LR = Table.Cells(31, 1).End(xlUp).Row


If LR < 11 Then
    LR = 0
Else
    LR = LR - 10
End If


Found = False


For j = 1 To LR
    DKey = Table.Cells(j, 1) & Table.Cells(j, 2)
    
    If SKey = DKey Then
       
    Select Case Range("F" & SIndex)
         
        Case Table.Cells(0, 4)
            Table.Cells(j, 4) = Val(Table.Cells(j, 4)) + Val(Range("B" & SIndex))
        Case Table.Cells(0, 5)
            Table.Cells(j, 5) = Val(Table.Cells(j, 5)) + Val(Range("B" & SIndex))
        Case Table.Cells(0, 6)
            Table.Cells(j, 6) = Val(Table.Cells(j, 6)) + Val(Range("B" & SIndex))
            
        End Select
                
                Found = True
                Exit For
    End If
Next j


If Not Found And LR < 30 Then


    Table.Cells(LR + 1, 1) = Range("A" & SIndex)
    Table.Cells(LR + 1, 2) = Range("E" & SIndex)
            
    Select Case Range("F" & SIndex)
                
    Case Table.Cells(0, 4)
        Table.Cells(LR + 1, 4) = Val(Range("B" & SIndex))
    Case Table.Cells(0, 5)
        Table.Cells(LR + 1, 5) = Val(Range("B" & SIndex))
    Case Table.Cells(0, 6)
        Table.Cells(LR + 1, 6) = Val(Range("B" & SIndex))
            
    End Select
    
    Found = True

في حالة امتلأ الجدول الحالي و لا يوجد تطابق في اي سطر و عدد الجداول التي تم البحث فيها اقل من العدد الكلي
ElseIf Not Found And TableIndex < UBound(Tables) Then

الدلة تستدعي نفسها لتبحث في الجدول التالي
    Found = UpdateTable(Tables, TableIndex + 1, SKey, SIndex)


End If


UpdateTable = Found


End Function

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

الرجاء وضع الكود علي هذا الجدول نظرا لصعوبه الكود علي

الرجاء الرد علي الرساله في الخاص

المصنف1.rar

تم تعديل ديسمبر 6, 2014 بواسطه ايهاب ممدوح

[ابو تراب]

جرب الكود

 

بالتوفيق

 

المصنف - تجربة.zip

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

بارك الله فيك ....ارجوا الرد علي الرساله الخاصه

[ابو تراب]

فضلا شيك على صندوق الرسائل

بالتوفيق