الرجاء تجربة الكود التالي وبعد أن يعمل قومي بدارسة الكود حيث أن المطلوب سهل جداً ويمكن أن يقوم بعمله أي مبتديء .. حاولت الإسهاب في الكود في كتابة المتغيرات لأوضح طريقة عمل الكود بالتفصيل دون شرح .. حاولي تتبع الكود ومعرفة ما يجري سطر بسطر باستخدام F8 .. ولا تنسي أن الهدف من المنتدى تعليمي وليس خدمي يقوم ببناء البرامج للناس دون أي مجهود منهم
Sub Test()
Dim vMenho, vLaho, vDate, vNumber, vVal, wsTransfer As Worksheet, wsMenho As Worksheet, wsLaho As Worksheet, sh As Worksheet, lrTransfer As Long, r As Long, cTarget As Long, c As Long, m As Long
Application.ScreenUpdating = False
Set wsTransfer = ThisWorkbook.Worksheets("Transfer")
Set wsMenho = ThisWorkbook.Worksheets("Menho")
Set wsLaho = ThisWorkbook.Worksheets("Laho")
lrTransfer = wsTransfer.Cells(Rows.Count, "B").End(xlUp).Row
vDate = wsTransfer.Range("A2").Value
vNumber = wsTransfer.Range("C2").Value
If vDate = Empty Or vNumber = Empty Then MsgBox "Date And Number Is Necessary", vbExclamation: Exit Sub
For r = 3 To lrTransfer
cTarget = wsTransfer.Cells(r, 4).Value
vMenho = wsTransfer.Cells(r, 5).Value
vLaho = wsTransfer.Cells(r, 6).Value
If (vMenho = Empty And vLaho = Empty) Or Not IsNumeric(cTarget) Then GoTo Skipper
If IsNumeric(vMenho) And Not IsEmpty(vMenho) Then
Set sh = wsMenho: c = cTarget: vVal = vMenho
ElseIf IsNumeric(vLaho) And Not IsEmpty(vLaho) Then
Set sh = wsLaho: c = cTarget: vVal = vLaho
End If
m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh.Cells(m, 1).Value = vDate
sh.Cells(m, 2).Value = wsTransfer.Cells(r, 2).Value
sh.Cells(m, 3).Value = vNumber
sh.Cells(m, c + 3).Value = vVal
Skipper:
Next r
Application.ScreenUpdating = True
MsgBox "Done...", vbInformation, "YasserKhalil Excel-Egy"
End Sub