dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,392
- Office Version
- 365
- 2016
- Platform
- Windows
I have some code that used to copy certain columns from every record in a table on one sheet to new rows of a table on another sheet. I didn't change anything but it has stopped copying the rows when I run the code.
This is the code:
Could someone help me work out what I did wrong please as I am still learning to code?
This is the code:
Code:
Sub cmdSend()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim desWS As Worksheet, srcWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("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
.ListObjects.Item("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"
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
'This is a procedure to add the client name to a seperate file
Call AddName
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
Could someone help me work out what I did wrong please as I am still learning to code?
Last edited: