ترحيل بيانات الى شيت

[ابو نبأ]

السلام عليكم

 

سؤالي هو : ترحيل بيانات المطابقة بين اربع اعمدة الى شيت مشمول

               وترحيل البيانات الغير مطابقة حتى اذا كانت مختلفة في عمود واحد

وكما مبين في الملف المرفق

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

السلام عليكم

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

[سليم حاصبيا]

  هل هذا ما تقصده\

 

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

[عبدالله باقشير]

السلام عليكم

 

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

Sub kh_trheel()
Dim Sht1 As Worksheet, Sht2 As Worksheet, Shp1 As Worksheet, Shp2 As Worksheet
Dim Lr As Long, R As Long
Dim t1 As String, t2 As String


Set Sht1 = Sheets("البيانات الرئيسية")
Set Sht2 = Sheets("البيانات الفرعية")
Set Shp1 = Sheets("مشمول")
Set Shp2 = Sheets("غير مشمول")

With Shp1.Range("A2:E2")
    Range(.Cells, .Cells.End(xlDown)).ClearContents
End With

With Shp2.Range("A2:E2")
    Range(.Cells, .Cells.End(xlDown)).ClearContents
End With

Lr = Sht1.Range("A" & Rows.Count).End(xlUp).Row

For R = 2 To Lr
    t1 = CStr(Sht1.Cells(R, "B")) & CStr(Sht1.Cells(R, "C")) & CStr(Sht1.Cells(R, "D")) & CStr(Sht1.Cells(R, "E"))
    t2 = CStr(Sht2.Cells(R, "B")) & CStr(Sht2.Cells(R, "C")) & CStr(Sht2.Cells(R, "D")) & CStr(Sht2.Cells(R, "E"))
    If t1 = t2 Then
        Shp1.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value = _
        Sht1.Cells(R, "A").Resize(1, 5).Value
    Else
        Shp2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value = _
        Sht2.Cells(R, "A").Resize(1, 5).Value
   
    End If
Next
Set Sht1 = Nothing: Set Sht2 = Nothing: Set Shp1 = Nothing: Set Shp2 = Nothing
End Sub

المرفق 2003

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

تحياتي

[ابو نبأ]

السلام عليكم

بارك الله فيكم

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

بارك الله فيك استاذ عبد الله

 

مشكور

 

وفقكم الله