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

**أيهاب ممدوح** · ديسمبر 3, 2014

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

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

**أيهاب ممدوح** · ديسمبر 3, 2014

للرفع

**ابو تراب** · ديسمبر 3, 2014

هلا ايهاب

جرب المرفق

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

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

**أيهاب ممدوح** · ديسمبر 3, 2014

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

**أيهاب ممدوح** · ديسمبر 3, 2014

الشرح لو سمحت

**ابو تراب** · ديسمبر 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

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

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

**أيهاب ممدوح** · ديسمبر 4, 2014

اخي الكريم

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

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

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

**ابو تراب** · ديسمبر 4, 2014

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

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

**أيهاب ممدوح** · ديسمبر 5, 2014

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

**أيهاب ممدوح** · ديسمبر 6, 2014

اخي الكريم

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

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

**ابو تراب** · ديسمبر 6, 2014

هلا ايهاب

الغرض من الكود هو اعطائك حرية تحديد اكثر من جدول لتعبئة البيانات على شرط ان كل جدول عدد صفوفه 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

**أيهاب ممدوح** · ديسمبر 6, 2014

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

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

المصنف1.rar

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

**ابو تراب** · ديسمبر 6, 2014

جرب الكود

بالتوفيق

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

**أيهاب ممدوح** · ديسمبر 7, 2014

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

**ابو تراب** · ديسمبر 7, 2014

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

بالتوفيق

تسجيل الدخول

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

الردود الموصى بها

أيهاب ممدوح

أيهاب ممدوح

ابو تراب

أيهاب ممدوح

أيهاب ممدوح

ابو تراب

أيهاب ممدوح

أيهاب ممدوح

ابو تراب

أيهاب ممدوح

أيهاب ممدوح

ابو تراب

أيهاب ممدوح

ابو تراب

أيهاب ممدوح

ابو تراب

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information