تعديل على كود نسخ

[samycalls2020]

السلام عليكم

هذا كود اخوتى الكرام يقوم بجلب بيانات من جدول فى ورقة DATA  الى جدول أخر فى ورقة AS

جدول DATA به صفوف فارغة فى أكثر من موضع  لأن بياناته مجلوبه بمعادلات

الكود يعمل جيداً .. والمراد تعديل فقط هو أن لاينقل الكود الصفوف الفارغة

Sub SS()
' كود نسخ

    Dim ws As Worksheet
    Dim sh As Worksheet
    Dim lr As Long
    Set ws = Sheets("DATA")
    Set sh = Sheets("AS")
      Application.ScreenUpdating = False
         sh.Range("B7:U406").ClearContents
        lr = sh.Cells(Rows.Count, 4).End(xlUp).Row + 1
        ws.Range("B7:U1026").SpecialCells(xlCellTypeVisible).Copy
        sh.Range("B" & lr).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        Application.ScreenUpdating = False
 End Sub

تم تعديل أبريل 12, 2018 بواسطه samycalls2020

[samycalls2020]

للرفع

[samycalls2020]

للرفع

[Ali Mohamed Ali]

تفضل أخى الكريم تمت الإجابة من قبل الأستاذ ياسر خليل

Sub Test()

    Dim ws      As Worksheet

    Dim sh      As Worksheet

    Dim lr      As Long

 

    Set ws = Sheets("DATA")

    Set sh = Sheets("AS")

 

    Application.ScreenUpdating = False

        sh.Range("B7:U406").ClearContents

        lr = sh.Cells(Rows.Count, 4).End(xlUp).Row + 1

        ws.Range("B7:U1026").SpecialCells(xlCellTypeVisible).Copy

        sh.Range("B" & lr).PasteSpecial xlPasteValues

        On Error Resume Next

            sh.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

        On Error GoTo 0

        Application.CutCopyMode = False

    Application.ScreenUpdating = False

End Sub

 

 

 

تم تعديل أبريل 12, 2018 بواسطه ali mohamed ali

[samycalls2020]

السلام عليكم أ/ على ..

وصلنى الكود من أ / ياسر مشكوراً .. وبتجربيته لم يعمل وإليكم المرفق

ترحيل بيانات.rar

[Ali Mohamed Ali]

تفضل أخى الكريم

 

 

 

ترحيل بيانات.rar

تم تعديل أبريل 12, 2018 بواسطه ali mohamed ali

[samycalls2020]

سلام الله عليك أ / على

تحياتى وتقديرى ..

أنا لدى الكود كما ارسلته لكم فى المرفق وهو كود يعمل جيداً

وكل ما أريدة فقط هو تعديل بسيط بحيث لا يجلب الصفوف الفارغة

وأليك المرفق مرة أخرى

ترحيل بيانات2.rar

تم تعديل أبريل 13, 2018 بواسطه samycalls2020

[Ali Mohamed Ali]

هذا الكود الستاذ ياسر خليل يفى بالغرض

Sub Test()

    Dim ws          As Worksheet

    Dim sh          As Worksheet

    Dim lr          As Long

    

    Set ws = Sheets("DATA")

    Set sh = Sheets("AS")

    

    Application.ScreenUpdating = False

        sh.Range("B3:U1026").ClearContents

        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 2

        ws.Range("B7:U1026").SpecialCells(xlCellTypeVisible).Copy

        sh.Range("B" & lr).PasteSpecial xlPasteValues

        On Error Resume Next

            sh.Columns(5).Replace 0, ""

            sh.Columns(5).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

        On Error GoTo 0

        Application.CutCopyMode = False

    Application.ScreenUpdating = False

End Sub

 

 

 

 

 

تم تعديل أبريل 13, 2018 بواسطه ali mohamed ali

[samycalls2020]

جزيل الشكر