نقل بيانات عمود اذا تحقق الشرط

[ابو حمادة]

ملف تجربه

Test01.xlsx.rar

ولكم منى جزيل الشكر 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

استخدم هذا الكود

Sub DataDate()
Dim ws As Worksheet, C As Range
Dim LR As Long, i As Integer, x As Integer
Dim Dt
Set ws = Sheets("ADD")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Dt = ws.Range("S2")
For Each C In ws.Range("E2:P2")
If C.Value = ws.Range("R2") Then
x = C.Column
End If
Next
i = 3
Do While i <= LR
If ws.Cells(i, "C") <= Dt And ws.Cells(i, "D") >= Dt Then
ws.Cells(i, "R") = ws.Cells(i, x)
End If
i = i + 1
Loop
End Sub

 

[ابو حمادة]

2 ساعات مضت, ابراهيم الحداد said:

السلام عليكم ورحمة الله

استخدم هذا الكود

Sub DataDate()
Dim ws As Worksheet, C As Range
Dim LR As Long, i As Integer, x As Integer
Dim Dt
Set ws = Sheets("ADD")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Dt = ws.Range("S2")
For Each C In ws.Range("E2:P2")
If C.Value = ws.Range("R2") Then
x = C.Column
End If
Next
i = 3
Do While i <= LR
If ws.Cells(i, "C") <= Dt And ws.Cells(i, "D") >= Dt Then
ws.Cells(i, "R") = ws.Cells(i, x)
End If
i = i + 1
Loop
End Sub

 

الله ينور استاذي الغالي

الف الف شكر

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