dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,392
- Office Version
- 365
- 2016
- Platform
- 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:
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?
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 IfCould 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?
