المساعدة في افضل كود ترحيل للبيانات الكثير والمتراكمة

[nicola]

اساتذة المنتدى والاعضاء الاكارم

السلام عليكم 

 

ارجو المساعدة في كود ترحيل جيد وفعال يستطيع التعامل مع بيانات كثيرة سوف ترحل قرابة بيانات (56) عامود

الي صفحة قاعدة البيانات

في المرفقات مثال يشرح المطلوب بشكل تفصيلي

 

 ولكم جزيل الشكر والتقدير 

ملف البيانات.rar

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

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

جرب الكود التالي

Sub Test()
    Dim wsControl       As Worksheet
    Dim wsData          As Worksheet
    Dim wsDB            As Worksheet
    Dim i               As Long
    Dim lrwsData        As Long
    Dim lrwsDB          As Long
    Dim newlr           As Long
    Dim cel             As Range
    Dim rg              As Range
    
    Application.ScreenUpdating = False
        Set wsControl = Sheets("Control")
        Set wsData = Sheets("Data")
        Set wsDB = Sheets("DB")
        
        Set rg = wsDB.UsedRange.Columns(2).Find(CDate(wsControl.[G1].Value2), , xlValues, xlWhole)
        If Not rg Is Nothing Then MsgBox "Date Existed", vbExclamation: Set rg = Nothing: Exit Sub
        
        lrwsDB = wsDB.Cells(Rows.Count, 5).End(xlUp).Row + 1
        lrwsData = wsData.Cells(Rows.Count, 4).End(xlUp).Row
        For i = lrwsData To 2 Step -1
            If Len(wsData.Cells(i, 4)) > 0 Then lrwsData = i: Exit For
        Next i

        wsData.Range("D2:BG" & lrwsData).Copy
        wsDB.Range("E" & lrwsDB).PasteSpecial xlPasteValues
        wsDB.Range("B" & lrwsDB).Value = wsControl.Range("G1").Value
        wsDB.Range("C" & lrwsDB).Value = wsControl.Range("G2").Value
        wsDB.Range("D" & lrwsDB).Value = wsControl.Range("G3").Value
        
        newlr = wsDB.Cells(Rows.Count, 5).End(xlUp).Row
        For Each cel In wsDB.Range("A" & lrwsDB & ":A" & newlr)
            cel.Value = cel.Row - 2
        Next cel
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[nicola]

جزاك الله كل خير 

هذا ما اريده بالفعل 

شكرا على جهدك ووقتك 

وزادك الله من علمه

 

لدي طلب بعد اذنك

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

تم تعديل يناير 12, 2017 بواسطه nicola

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

وجزيت بمثله أخي الكريم

تم تعديل الكود السابق ليناسب طلبك الجديد

[nicola]

استاذي الكريم

 

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

 

يعجز اللسان عن شكرك

بارك الله فيك

وجزاك الله كل خير

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

وجزيت خيراً بمثل ما دعوت لي أخي الكريم

تقبل تحياتي