ترحيل بيانات فاتورة من ورقة لورقة اخرى مع تجاهل الصفوف الفارغة

[عبدالفتاح في بي اكسيل]

السلام عليكم 

اريد كود  يرحل البيانات  فاتورة من ورقة  لاخرى  بشرط  تجاهل  الصفوف  الفارغة  التي  تبدا  من A22 : A42  في حالة ان  هذه الخلايا فارغة  

1‬.xlsx

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

استبدل اسماء الشيتات (لسهولة نسخ الكود ولصقه الافضل استعمال اللغة الاجنبية في تسمية الصفحات)

شيت المصدر الى SOURCE_SH

شيت الهدف الى TARGET_SH

ونفذ هذا الكود

Option Explicit
Sub tranfere_data()
Dim S As Worksheet, T As Worksheet
Dim RGG5S As Range, RGB11S As Range, RGAS As Range
Dim r%, x1%, x2%
Set S = Sheets("SOURCE_SH"): Set T = Sheets("TARGET_SH")
Set RGG5S = S.Range("G5").Resize(5)
Set RGB11S = S.Range("B11").Resize(4)
 With T
  .Range("G6").Resize(5).ClearContents
  .Range("B12").Resize(4).ClearContents
  .Range("a18").Resize(18, 7).ClearContents
 End With
x1 = Application.CountA(RGG5S)
x2 = Application.CountA(RGB11S)

If x1 + x2 <> 9 Then
    MsgBox "Insufficient data in SOURCE_SH" & Chr(10) & _
    RGG5S.Address & Chr(10) & "OR" & Chr(10) & _
    RGB11S.Address
Exit Sub
End If
Set RGAS = S.Range("A21").CurrentRegion.Columns(1)
r = Application.CountA(RGAS)
If r = 1 Then
 MsgBox "No data in SOURCE_SH to transfere"
Exit Sub
End If
Set RGAS = S.Range("a22").Resize(r - 1, 7)
 With T
 .Range("G6").Resize(5).Value = RGG5S.Value
 .Range("B12").Resize(4).Value = RGB11S.Value
 .Range("A18").Resize(RGAS.Rows.Count, RGAS.Columns.Count).Value = RGAS.Value
 End With

End Sub

الملف مرفق

 

Transfer_data_.xlsm

[عبدالفتاح في بي اكسيل]

شكر اخي سليم  ولكن عندما  اقوم بالترحيل   يوجد صفوف  فارغة  في الصفحة  TARGET_SH   وانا   لا اريدها 

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

تم التعديل على الماكرو كما تريد

Option Explicit
Sub tranfere_data()
Dim S As Worksheet, T As Worksheet
Dim RGG5S As Range, RGB11S As Range, RGAS As Range
Dim r%, x1%, x2%
Set S = Sheets("SOURCE_SH"): Set T = Sheets("TARGET_SH")
Set RGG5S = S.Range("G5").Resize(5)
Set RGB11S = S.Range("B11").Resize(4)
 With T
  .Range("G6").Resize(5).ClearContents
  .Range("B12").Resize(4).ClearContents
  .Range("a18").Resize(18, 7).ClearContents
  .Rows.Hidden = False
 End With
x1 = Application.CountA(RGG5S)
x2 = Application.CountA(RGB11S)

If x1 + x2 <> 9 Then
    MsgBox "Insufficient data in SOURCE_SH" & Chr(10) & _
    RGG5S.Address & Chr(10) & "OR" & Chr(10) & _
    RGB11S.Address
Exit Sub
End If
Set RGAS = S.Range("A21").CurrentRegion.Columns(1)
r = Application.CountA(RGAS)
If r = 1 Then
 MsgBox "No data in SOURCE_SH to transfere"
Exit Sub
End If
Set RGAS = S.Range("a22").Resize(r - 1, 7)
 With T
 .Range("G6").Resize(5).Value = RGG5S.Value
 .Range("B12").Resize(4).Value = RGB11S.Value
 .Range("A18").Resize(RGAS.Rows.Count, RGAS.Columns.Count).Value = RGAS.Value
 .Range("A18:A35").SpecialCells(4).EntireRow.Hidden = True
 End With

End Sub

 

[عبدالفتاح في بي اكسيل]

شكرا  اخي  سليم  هذا  المطلوب