ترحيل واستيراد

[أ/حكيم]

الاخوة أعضاء المنتدى الكرام أرجو مساعدتي في استيراد بيانات من عدة أوراق الى ورقة كما هو موضح في المرفق لكم جزيل الشكر 

وثائق.zip

[أ/حكيم]

للرفع

[شوقي ربيع]

السلام عليكم

Option Explicit

Sub test()
Dim sh As Worksheet, Ws As Worksheet: Set sh = Sheets("غير مكتمل")
Dim lr As Long, Lrw As Long
Dim i As Integer, r As Integer
lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
sh.Range("C11:AI" & lr).ClearContents

For Each Ws In Worksheets
    Lrw = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row + 1
    For i = 11 To Lrw
        lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row + 1
        If Ws.Range("AI" & i) = "لا" Then
            For r = 3 To 35
            sh.Cells(lr, r) = Ws.Cells(i, r)
            Next r
        End If
    Next i
Next Ws
End Sub

وثائق.rar

[أ/حكيم]

الاخ العزيز شوقي ربيع ربما الملف معطوب ... وعند وضع الكود في ملفي يتم الترحيل وتعديل رقم العمود من 2 الى 3  في المتغير ir   يعمل الكود ولكن يتم تكرار 10 اسماء في الأخير و أحيانا يبدأ الترحيل من الصف الثاني وشكرا

تم تعديل يونيو 11, 2014 بواسطه أ/حكيم

[شوقي ربيع]

Option Explicit

Sub test()
Dim sh As Worksheet, Ws As Worksheet: Set sh = Sheets("غير مكتمل")
Dim lr As Long, Lrw As Long
Dim i As Integer, r As Integer
lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row + 1
sh.Range("C11:AI" & lr).ClearContents

For Each Ws In Worksheets
    Lrw = Ws.Cells(Ws.Rows.Count, 2).End(xlUp).Row + 1
    For i = 11 To Lrw
        lr = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row + 1
        If Ws.Range("AI" & i) = "لا" Then
            sh.Range("B" & lr) = lr - 10
            For r = 3 To 35
            sh.Cells(lr, r) = Ws.Cells(i, r)
            Next r
        End If
    Next i
Next Ws
End Sub

[أ/حكيم]

الكود يستورد الاسماء مرتين +1 هل يمنك التعديل فيه وشكرا

وثائق2.zip

تم تعديل يونيو 12, 2014 بواسطه أ/حكيم