delete blank rows based on empty cells into column from sheet to another

[abdo meghari]

HI

I want to copy data from sheet1 to sheet2 . should copy with all format and formula without empty rows. the empty rows depend on column A if any cell is empty in column A where located from row 21 until before row SUB TOTAL ,then should delete it because I will add rows before row SUB TOTAL every time
so any empty row from ROW 21 up to before row SUB TOTAL should delet e it

vv1.xlsm
	A	B	C	D	E	F	G
1						INVOICE
2		COMPANY LTD
3
4						DATE
5						2022/08/02
6						INVOICE
7						BSJD-146
8						CUS
9						CUS-146
10
11	TO:				CONSIGNEE
12	NAME
13	ADDRESS
14	PHONE
15	EMAIL
16
17	OREDER	DATE	FR	SAL		(FOB)	TREM
18	PUR-144
19
20	ITEM	DESCRIBE	TYPE	ORIGIN	QTY	UNIT	TOTAL
21	1	BS 1200R20	G580	THI	200.00	120.00	24,000.00
22	2	BS 1200R20	G580	JAP	230.00	110.00	25300.00
23							0.00
24							0.00
25							0.00
26							0.00
27	SUB TOTAL						49300.00
28	TAX						1873.40
29	FREIGHT						0.00
30	OTHERS						0.00
31	TOTAL						$51,173.40
32	For questions concerning this invoice, please contact
33	Name, (321) 456-7890, Email Address
34	www.yourwebaddress.com
sheet1

Cell Formulas
Range	Formula
F5	F5	=TODAY()
G21:G26	G21	=E21*F21
G27	G27	=SUM(G21:G22)
G28	G28	=SUM(G27)*3.8%
G31	G31	=G27+G28+G29+G30

result
should be

vv1.xlsm
	A	B	C	D	E	F	G
1						INVOICE
2		COMPANY LTD
3
4						DATE
5						2022/08/02
6						INVOICE
7						BSJD-146
8						CUS
9						CUS-146
10
11	TO:				CONSIGNEE
12	NAME
13	ADDRESS
14	PHONE
15	EMAIL
16
17	OREDER	DATE	FR	SAL		(FOB)	TREM
18	PUR-144
19
20	ITEM	DESCRIBE	TYPE	ORIGIN	QTY	UNIT	TOTAL
21	1	BS 1200R20	G580	THI	200.00	120.00	24,000.00
22	2	BS 1200R20	G580	JAP	230.00	110.00	25300.00
23	SUB TOTAL						49300.00
24	TAX						1873.40
25	FREIGHT						0.00
26	OTHERS						0.00
27	TOTAL						$51,173.40
sheet2

Cell Formulas
Range	Formula
F5	F5	=TODAY()
G21:G22	G21	=E21*F21
G23	G23	=SUM(G21:G22)
G24	G24	=SUM(G23)*3.8%
G27	G27	=G23+G24+G25+G26

I hope this clear

 

[Alex Blakenburg]

See if this does what you need:

Sub CopyAndDeleteRows()
    
    Application.ScreenUpdating = False

    Dim shtOrig As Worksheet, shtCopy As Worksheet
    Dim rowSubTot As Long, rowLastInv As Long
    Dim rRowOrig As Range
      
    Set shtOrig = Worksheets("Sheet1")
    Set shtCopy = Worksheets("Sheet2")
    
    With Application
        rowSubTot = .IfError(.Match("SUB TOTAL", shtOrig.Range("A:A"), 0), 0)
    End With

    If rowSubTot = 0 Then
        MsgBox "Sub Total not found on " & shtOrig.Name
        Exit Sub
    End If
    ' Copy sheet
    shtOrig.Cells.Copy Destination:=shtCopy.Range("A1")

    ' Copy row heights
    For Each rRowOrig In shtOrig.UsedRange.Rows
        shtCopy.Rows(rRowOrig.Row).RowHeight = rRowOrig.RowHeight
    Next rRowOrig

    ' Delete Blank Rows before Sub Total
    With shtCopy
        rowLastInv = .Range("A" & rowSubTot).End(xlUp).Row
        If rowLastInv > 20 Then
            .Range(.Cells(rowLastInv + 1, "A"), .Cells(rowSubTot - 1, "A")).EntireRow.Delete
        End If
        shtCopy.Activate
        shtCopy.Range("A1").Activate
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
        
End Sub

 

[vcoolio]

Hello Abdo,

See if this helps:-

Option Explicit
Sub AbdoTest()

Dim lr As Long: lr = Sheet1.Cells.Find("*Sub*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

Application.ScreenUpdating = False
              
        With Sheet1.Range("A20:A" & lr)
                .AutoFilter 1, ""
                .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
                .AutoFilter
        End With
        
        Sheet1.UsedRange.Copy Sheet2.[A1]

Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[abdo meghari]

@Alex Blakenburg fantastic !
just I try to modify your code should clear contents specific cells(F5,F7,F9,A18) in sheet1 after copy to sheet2 espicially from row21 up to until before sub total . I try to put it in the end of code like this

With shtOrig
    rowLastInv = .Range("A" & rowSubTot).End(xlUp).Row
        If rowLastInv > 20 Then
            .Range(.Cells(rowLastInv + 1, "A"), .Cells(rowSubTot - 1, "A")).ClearContents
            End If
            End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

but doesn't work , can you guide me please?

 

[abdo meghari]

@vcoolio nice work without loop . perfect by filter, but unfortunately also delete from sheet1 should not delete it
also I would just clear contents from row21 up to before sub total & cells(F5,F7,F9,A18) in sheet1 after copy to sheet2
thanks

 

[Alex Blakenburg]

@Alex Blakenburg fantastic !
just I try to modify your code should clear contents specific cells(F5,F7,F9,A18) in sheet1 after copy to sheet2 espicially from row21 up to until before sub total .

Yet another reason to avoid merged cells

With my original code before Application.CutCopyMode = False put this:

    Dim i As Long
    Dim arr As Variant
    arr = Array("F5", "F7", "F9", "A18")
    For i = 0 To UBound(arr)
        shtOrig.Range(arr(i)).MergeArea.ClearContents
    Next i

 

[abdo meghari]

thanks but also I want clearcontents from row 21 to last row before SUBTOTAL

 

[abdo meghari]

I can't update last post . so when clearcontents from row 21 to last row before SUBTOTAL . should keep the formula in coumn G .

 

[Alex Blakenburg]

I can't update last post . so when clearcontents from row 21 to last row before SUBTOTAL . should keep the formula in coumn G .

Add the below after what I gave you previously

    With shtOrig
        .Range(.Cells(21, "A"), .Cells(rowSubTot - 1, "F")).ClearContents
    End With

 

[abdo meghari]

@Alex Blakenburg thanks very much for every thing