extra line being made

D

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,352
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a table that when filled out is copied to a table in another sheet. The first time the table is copied, it will also make a blank table entry at the bottom of the table on the destination table. Someone helped me with some code to remove the extra blank row but it appears to have come back for some reason. It only occurs on the first time data is copied to the table. Therefore, if rows are copied more than once, the blank row won't be there but if they are only copied once, there will be a blank row at the bottom.

Here is my code to copy the rows:

Code: 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet")
        Set desWS = ThisWorkbook.Sheets("Costing_tool")
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, x As Long, header As Range
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
        lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS.Range("A:A,B:B,H:H")
        If lastRow2 < 5 Then
            lastRow2 = 5
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
                    desWS.ListObjects.Item("tblCosting").ListRows.Add
                End If
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else
            lastRow2 = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            desWS.ListObjects.Item("tblCosting").ListRows.Add
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Dim oLst As ListObject
'----------------------------------------------------------
'''''''deletes last row in tblCosting if it is a blank row
    Set desWS = ActiveSheet
    If desWS.ListObjects.Count > 0 Then
        For Each oLst In desWS.ListObjects
            If oLst.ListRows.Count > 0 Then
                For i = oLst.ListRows.Count To 1 Step -1
                    If WorksheetFunction.CountA(oLst.ListRows(i).Range) = 0 Then
                        oLst.ListRows(i).Delete
                    End If
                Next i
            End If
        Next oLst
    End If


Could someone help me with code that will remove the extra row on the first time a copy procedure is performed if it is blank please?
 
Sort by date Sort by votes
I changed around the code at the end of cmdSend.

It now reads
Code: 
'----------------------------------------------------------
'''''''deletes last row in tblCosting if it is a blank row
    Set desWS = ThisWorkbook.Worksheets("Costing_tool")
    If desWS.ListObjects.Count > 0 Then
        For Each oLst In desWS.ListObjects
            If oLst.ListRows.Count > 0 Then
                oLst.ListRows(oLst.ListRows.Count).Delete
        End If
        Next oLst
    End If
End Sub

This will always delete the last row in tblCosting but I need it to only delete if the row is blank. Can you help me with this please?
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
The new row is not completely blank as it does have some formulas in it.
 
Upvote 0
If only 1 row is in npss_quote, it copies to 1 row in the costing_tool with no extra blank rows. If 2 rows are copied across, the 2 rows appear in costing_tool but there is also an extra blank row, making 3 rows in total. If 3 rows are copied across, 3 rows appear in costing_tool with an extra blank row to make a total of 4 rows.
 
Upvote 0
In that case try this way....replace your CmdSend_Click, with this one

Code: 
Private Sub CmdSend_Click()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet")
        Set desWS = ThisWorkbook.Sheets("Costing_tool")
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, x As Long, header As Range
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
        lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    With srcWS.Range("A:A,B:B,H:H")
        If lastRow2 < 5 Then
            lastRow2 = 5
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
                    desWS.ListObjects.Item("tblCosting").ListRows.Add
                End If
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else
            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            desWS.ListObjects.Item("tblCosting").ListRows.Add
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Dim oLst As ListObject
Dim lr As Long, rng As Range
lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 4 Step -1
    Set rng = desWS.Cells(i, 1)
    If WorksheetFunction.CountBlank(rng) = 1 Then
        desWS.Rows(i).Delete
    End If
Next i
End Sub
 
Last edited:
Upvote 0
Thank you Michael, that works great now.

I would love to learn what you did. Here is the original code I had, would it be possible to explain what you changed please?

Code: 
Private Sub CmdSend_Click()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet")
        Set desWS = ThisWorkbook.Sheets("Costing_tool")
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, x As Long, header As Range
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
        lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    With srcWS.Range("A:A,B:B,H:H")
        If lastRow2 < 5 Then
            lastRow2 = 5
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
                    desWS.ListObjects.Item("tblCosting").ListRows.Add
                End If
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else
            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            desWS.ListObjects.Item("tblCosting").ListRows.Add
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Dim oLst As ListObject
'----------------------------------------------------------
'''''''deletes last row in tblCosting if it is a blank row
    'Set desWS = ThisWorkbook.Worksheets("Costing_tool")
    If desWS.ListObjects.Count > 0 Then
        For Each oLst In desWS.ListObjects
            If oLst.ListRows.Count > 0 Then
                For i = oLst.ListRows.Count To 1 Step -1
                    If WorksheetFunction.CountA(oLst.ListRows(i).Range) = 0 Then
                        oLst.ListRows(i).Delete
                    End If
                Next i
            End If
        Next oLst
    End If
End Sub
 
Upvote 0
I replaced this

Code: 
Set desWS = ThisWorkbook.Worksheets("Costing_tool")
    If desWS.ListObjects.Count > 0 Then
        For Each oLst In desWS.ListObjects
            If oLst.ListRows.Count > 0 Then
                For i = oLst.ListRows.Count To 1 Step -1
                    If WorksheetFunction.CountA(oLst.ListRows(i).Range) = 0 Then
                        oLst.ListRows(i).Delete
                    End If
                Next i
            End If
        Next oLst
    End If

With this....using ranges instead of tables

Code: 
Dim lr As Long, rng As Range
lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 4 Step -1
    Set rng = desWS.Cells(i, 1)
    If WorksheetFunction.CountBlank(rng) = 1 Then
        desWS.Rows(i).Delete
    End If
Next i
 
Upvote 0
Could you please put a comment above each line explaining what it is doing?
 
Upvote 0
Don't you ever have a day off...:LOL:

Code: 
Option Explicit
'declare the variables
Dim lr As Long, rng As Range
'find the last row in Col "A" on the Costing Tool Sheet
lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
'loop from the last row back to the header row
For i = lr To 4 Step -1
    'set the range of the cell in the loop in Column "A"
    Set rng = desWS.Cells(i, 1)
    'if the cell in the loop (i,1) is balnk....count it as 1
    If WorksheetFunction.CountBlank(rng) = 1 Then
     ' if the count = 1 then delete the row
        desWS.Rows(i).Delete
    End If
'loop to the next cell
Next i
 
Upvote 0
No, not really. What about you?

After searching for work for about 7 years, I am so thankful to have a job that I am good at. I enjoy my job so much that I love working on it in my spare time.

I actually took my kids out to a local play centre and I was just replying to emails on my phone while I was there supervising them.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA to copy data from one worksheet to another (only specific columns)
Replies
2
Views
816
SpireiteSteve
S
N
  • Question
My code is suddenly really slow
Replies
1
Views
168
RobP
R
J
  • Question
Run-time error '91"- bypass and add comment
Replies
3
Views
552
Alex Blakenburg
A
H
  • Solved
Amend the VBA code to Filter Columns Instead of Rows
Replies
9
Views
203
Akuini
Akuini
D
  • Question
Code not being copied between two tables
Replies
2
Views
375
dpaton05
D

Forum statistics

Threads
1,215,754
Messages
6,126,681
Members
449,328
Latest member
easperhe29

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top