ترحيل بيانات بشرط معين

[checles]

اعرض الملف

ترحيل بيانات بشرط معين

---

السلام عليكم 

برجاء المساعده في ترحيل البيانات من شيت في العمود E بايانات بعد النقل يمسح البايانات 

عند الترحيل مره اخر يرحل تحت السابق 

وشكرا 

---

• صاحب الملف
  checles
• تمت الاضافه
  19 مار, 2023
• الاقسام
  قسم الإكسيل

 

[محمد هشام.]

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

تفضل اخي 

Sub test1()
Dim Dernlige As Long
Dim wsData  As Worksheet
Dim wsDest  As Worksheet
Dim lr      As Long
Dim i As Integer

Application.ScreenUpdating = False
Set wsData = Worksheets("Date Sales")
Set wsDest = Worksheets("sales")

lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1
   For i = 3 To lr
     If Cells(i, 5) <> "" Then
     
       Dernlige = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
       
       Range(Cells(i, 1), Cells(i, 6)).Copy Destination:=wsDest.Cells(Dernlige, 1)
       
          End If
    Next i
    wsData.Range("A3:F" & lr).ClearContents
    
End Sub

 

 

Book1_v3.xlsm

تم تعديل مارس 20, 2023 بواسطه Mohamed Hicham

[محي الدين ابو البشر]

وعليكم السلام

ممكن خيار آخر

Sub test()
Dim a, temp
a = Cells(1, 1).CurrentRegion
 temp = Application.Transpose(Filter(Evaluate("transpose(if((" & Columns(5).Address & "<>""" & """)*(" & Columns(5).Address & "<>""" _
                    & "Invoice No" & """),row(1:" & Rows.Count & ")))"), False, 0))
Cells(1, 1).CurrentRegion.Offset(2).ClearContents
 a = Application.Index(a, temp, [{1, 2, 3, 4, 5, 6}])
 With Sheets("sales")
 .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(a), UBound(a, 2)) = a
 End With
End Sub