help adjusting code delete empty rows based on condition from sheet1 to sheet2

hello
i would some help about adjusting code when transfer data of invoice from sheet1 to sheet2 the sheet1 contains some empty rows when i transfer i don't want transfer the empty rows to sheet2 only filling the data in sheet1 begins from range a3:e31 the empty rows should delete from a19:e30 if the cells a19: a30= empty i make attention the range from a19:e30 don't delete in sheet1 because i need them i don't want in sheet2 when i transfer and here the notes i would a31: e31 connect with the last filling row value for instance the last filling row value in range a22:e22 =200
then the a31:e31=200 i know it this complicated qustion i hope this help to solve my problem and this is my code :

HTML Code:

---

Sub TransferData()
Dim x As Integer

    Dim Target As Range
  Dim LastRow As Long 
 Dim R As Long
For x = 30 To 19 Step -1 
 If sheet2.Range("A" & x).Value = vbNullString Then
sheet2.Range("A" & x).EntireRow.Delete 
  Next x   
LastRow = sheet1.Cells(.Rows.Count, "A").End(xlUp).Row 
  Set Target = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp) 
 For R = 2 To LastRow     
 sheet1 .Range(sheet1.Cells(R, 1), sheet1.Cells(R, 5)).Copy _               
Destination:=Target.Offset(R - 2)        With Target.Offset(R - 2, 4)         
  If .HasFormula Then .Value =sheet1 .Cells(R, 5).Value   
  End With       
  Next R
    On Error Resume Next                 
  Target.Offset(R - 3, 5).Value = WorksheetFunction.Sum(sheet2.Range("E3:E35"))End Sub

---

Same code reformatted

Code:

---

Sub TransferData()
Dim x As Integer
Dim Target As Range
Dim LastRow As Long 
Dim R As Long

For x = 30 To 19 Step -1 
  If sheet2.Range("A" & x).Value = vbNullString Then _
      sheet2.Range("A" & x).EntireRow.Delete 
Next x 
 
LastRow = sheet1.Cells(.Rows.Count, "A").End(xlUp).Row 
Set Target = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp)
 
For R = 2 To LastRow     
  sheet1 .Range(sheet1.Cells(R, 1), sheet1.Cells(R, 5)).Copy _               
      Destination:=Target.Offset(R - 2) 
     
  With Target.Offset(R - 2, 4)         
      If .HasFormula Then .Value =sheet1 .Cells(R, 5).Value   
  End With       
Next R

On Error Resume Next                 
Target.Offset(R - 3, 5).Value = WorksheetFunction.Sum(sheet2.Range("E3:E35"))

End Sub

---

Code:

---

Option Explicit

Sub TransferData()
Dim TargetRow As Long
Dim LastRow As Long
Dim Rw As Long
Dim rSource As Range
 
LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
TargetRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
 
For Rw = 2 To LastRow
  Set rSource = Sheet1.Range(Sheet1.Cells(Rw, 1), Sheet1.Cells(Rw, 5))
  If rSource.Cells(1) <> "" Then
      rSource.Copy
      Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteValues
      TargetRow = TargetRow + 1
  End If
Next Rw
End Sub

---

Quote:

---

Originally Posted by SamT

Same code reformatted

Code:

---

Sub TransferData()
Dim x As Integer
Dim Target As Range
Dim LastRow As Long 
Dim R As Long

For x = 30 To 19 Step -1 
  If sheet2.Range("A" & x).Value = vbNullString Then _
      sheet2.Range("A" & x).EntireRow.Delete 
Next x 
 
LastRow = sheet1.Cells(.Rows.Count, "A").End(xlUp).Row 
Set Target = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp)
 
For R = 2 To LastRow     
  sheet1 .Range(sheet1.Cells(R, 1), sheet1.Cells(R, 5)).Copy _               
      Destination:=Target.Offset(R - 2) 
     
  With Target.Offset(R - 2, 4)         
      If .HasFormula Then .Value =sheet1 .Cells(R, 5).Value   
  End With       
Next R

On Error Resume Next                 
Target.Offset(R - 3, 5).Value = WorksheetFunction.Sum(sheet2.Range("E3:E35"))

End Sub

---

---

thanks for your replying it' long time to reply someone my post published 3 days ago i expect for you or anyone to help my problem

Quote:

---

Originally Posted by SamT

Code:

---

Option Explicit

Sub TransferData()
Dim TargetRow As Long
Dim LastRow As Long
Dim Rw As Long
Dim rSource As Range
 
LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
TargetRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
 
For Rw = 2 To LastRow
  Set rSource = Sheet1.Range(Sheet1.Cells(Rw, 1), Sheet1.Cells(Rw, 5))
  If rSource.Cells(1) <> "" Then
      rSource.Copy
      Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteValues
      TargetRow = TargetRow + 1
  End If
Next Rw
End Sub

---

---

thanks your code really work but not as i want i would transfer data the same formating table
a i attache my file to understand more


https://ufile.io/39xbgskh

i hope this file help anyone to understand it

Code:

---

Option Explicit

Sub TransferData()
Dim TargetRow As Long
Dim LastRow As Long
Dim Rw As Long
Dim rSource As Range
 
LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
TargetRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
 
For Rw = 2 To LastRow
  Set rSource = Sheet1.Range(Sheet1.Cells(Rw, 1), Sheet1.Cells(Rw, 5))
  If rSource.Cells(1) <> "" Then
      rSource.Copy
      Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteValues
      Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteFormats
      TargetRow = TargetRow + 1
  End If
Next Rw
End Sub

---

Quote:

---

Originally Posted by SamT

Code:

---

Option Explicit

Sub TransferData()
Dim TargetRow As Long
Dim LastRow As Long
Dim Rw As Long
Dim rSource As Range
 
LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
TargetRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
 
For Rw = 2 To LastRow
  Set rSource = Sheet1.Range(Sheet1.Cells(Rw, 1), Sheet1.Cells(Rw, 5))
  If rSource.Cells(1) <> "" Then
      rSource.Copy
      Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteValues
      Sheet2.Cells(TargetRow, "A").PasteSpecial Paste:=xlPasteFormats
      TargetRow = TargetRow + 1
  End If
Next Rw
End Sub

---

---

it does work code but it still simple problems some data of cells it doesn't show in sheet2

date and order no and value i no know why? you can check my file and tell me what happen

i'm really sorry sam your code is perfect the problem is in my attached file i tested another workbook is succeeding

:thumb