المطلوب تصحيح كود ترحيل

[عادل ابوزيد]

السلام عليكم  

بالمرفق كود يقوم بترحيل المدى المطلوب ترحيله (هذا المدى بياناته لا تكون ممتلئة بالكامل) فى اخر البيانات فى عمود اخر .. المشكلة عنه يتم الترحيل كل مرة فى اخر عدد من الصفوف الخاصة بالمدى المطلوب ترحيل بياناته الذى يكون غير ممتلئ بياناته وبالتالى تظهر مساحة فارغة من عملية الترحيل والاخرى 

برجاء حل المشكلة

Book2.xls

[محمد هشام.]

تفضل اخي ربما هدا ما تقصده 

نفس الفكرة لاكن بطرق مختلفة يمكنك اختيار ما يناسيك

Sub test1()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim lastrow As Long, ligne As Range, search As Range
Set ligne = [U4]: Set search = [L19]
lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1

If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات  " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
A = [L19:Q51].Value
If ligne = 0 Then
[U4].Resize(UBound(A), UBound(A, 2)).Value2 = A
   Else
 Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A
End If
 MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation
End Sub

'***********************او****************************
Sub test2()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim F As Variant, Data As Range
Dim lastrow As Long, ligne As Range, search As Range
Set ligne = [U4]: Set search = [L19]
Set Data = WS.Range("L19:Q51")

If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات  " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
F = Application.Index(Data, Evaluate("Row(1:" & Data.Rows.Count & " )"), Array(1, 2, 3, 4, 5, 6))
lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1
    If ligne = 0 Then
    WS.[U4].Resize(UBound(F, 1), UBound(F, 2)) = F
     Else
    WS.Range("U" & lastrow).Resize(UBound(F, 1), UBound(F, 2)) = F
    End If
 MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation
End Sub

'***********************او****************************
Sub test3()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim lastrow As Long, ligne As Range, search As Range
Set ligne = [U4]: Set search = [L19]
  Set Data = WS.Range("L19:L51,M19:M51,N19:N51,O19:O51,P19:P51,Q19:Q51")
  Tbl = Réf(Data)
lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1
If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات  " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
If ligne = 0 Then
[U4].Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl
 Else
WS.Range("U" & lastrow).Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl
End If
 MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation

End Sub
Function Réf(Data)
  K = Data.Rows.Count: Col = Data.Areas.Count
  Dim Tbl():  ReDim Tbl(1 To K, 1 To Col)
  For i = 1 To Col
    For J = 1 To K: Tbl(J, i) = Data.Areas(i)(J): Next J
  Next i
  Réf = Tbl
End Function

 

Book2.xls

[عادل ابوزيد]

السلام عليكم

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

ولى طلب اخير ممكن شرح الكود وليكن الاول حتى يمكننى التعديل فى  الملف الاصلى  .. مع جزيل الشكر

[محمد هشام.]

Sub test1()
Dim WS As Worksheet: Set WS = ActiveSheet '<<<---- Worksheets("27-10-2023الى2-11-2023") 'اسم ورقة العمل

Dim lastrow As Long, ligne As Range, search As Rang
Set ligne = [U4] '<<<----' خلية اللصق

Set search = [L19] '<<<--  اي القيمة التي تم جلبها من الخلية  '<<<---اول تاريخ على الجدول ("A4") '
                        
'("U")'  تحديد اخر خلية بها بيانات من عمود
lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1
' لمنع التكرار 
 '***********************
'("U") 'التحقق من وجود نفس تاريخ المدفوعات مسبقا في عمود ' 
' في حالة وجوده يتم ايقاف تنفيد الكود مع رسالة اشعار
If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات  " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub

A = [L19:Q51].Value   ''<<<----'نطاق البيانات المرحلة

If ligne = 0 Then   ' '<<<----التحقق من عدم وجود قيمة في خلية اللصق

' U4'في حالة فراغها يتم لصق البيانات ابتداءا من الخلية
[U4].Resize(UBound(A), UBound(A, 2)).Value2 = A
   Else
   
' U ' في حالةوجودقيمة يتم لصق البيانات بعد اخر صف به بيانات من عمود
 
 Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A
End If

 MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation
End Sub

 

[عادل ابوزيد]

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