dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,375
- Office Version
- 365
- 2016
- Platform
- Windows
I have some code that correctly identifies a workbook and sheet to copy quotes to based on the date of the quote. The workbooks are financial year documents and different rows of a quote may relate to different financial years. The sheets are named by month and the name of the sheet where the quote is put is determined in some of the end columns of my table. What do I need add to the code to open the workbook, do the copy and paste, save the wb then close it? Both source wb and destination wb are in the same folder.
For row 5, which is the first row in the table,
A5: date
Z5: =TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "mmmm")
AA5: =TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "yyyy")
AG5: =IF(MONTH(A5)<7,YEAR(A5)-1,YEAR(A5))
AH5: =IF(MONTH(A5)<7,YEAR(A5),YEAR(A5)+1)
AI5: =CONCATENATE(AG5," - ",AH5)
AJ5: =CONCATENATE(AI5," ","NPSS Work Allocation Sheet.xlsm")
AK5: =CONCATENATE(AI5," ","Internal Work Allocation Sheet.xlsm")
Here is my code that works for copying the quotes to the destination workbook that is already open.
I have been trying to work this out al morning but I just can't seem to get it. Nothing I try seems to work and I need some help please.
As I have mentioned, the code above works for when the wb is open but the quote may have parts relevant to about 10 years in the future. As they are financial years, I don't want to have to have 10 yearly documents open. I have code above that checks the date of every row in the table and pastes the row at the bottom of the relevant wb. I need code that checks to see if it is already open, and if it is, complete the copying procedure, but if it isn't open, I need code to open the wb, paste the row at the bottom of the list, sort them by date, save it then close the wb.
Any help would be greatly appreciated!
Dave
For row 5, which is the first row in the table,
A5: date
Z5: =TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "mmmm")
AA5: =TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "yyyy")
AG5: =IF(MONTH(A5)<7,YEAR(A5)-1,YEAR(A5))
AH5: =IF(MONTH(A5)<7,YEAR(A5),YEAR(A5)+1)
AI5: =CONCATENATE(AG5," - ",AH5)
AJ5: =CONCATENATE(AI5," ","NPSS Work Allocation Sheet.xlsm")
AK5: =CONCATENATE(AI5," ","Internal Work Allocation Sheet.xlsm")
Here is my code that works for copying the quotes to the destination workbook that is already open.
Code:
Sub cmdCopy()
Dim wsDst As Worksheet
Dim wsSrc As Worksheet
Dim tblrow As ListRow
Dim Combo As String
Dim sht As Worksheet
Dim tbl As ListObject
Dim LastRow As Long
Dim DocYearName As String
Application.ScreenUpdating = False
'assign values to variables
Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
For Each tblrow In tbl.ListRows
If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
Exit Sub
End If
Next tblrow
For Each tblrow In tbl.ListRows
Combo = tblrow.Range.Cells(1, 26).Value
'lastrow = Worksheets(Combo).Cells(Rows.Count, "A").End(xlUp).Row + 1 'number of first empty row in column A of Combo
If tblrow.Range.Cells(1, 6).Value = "Ang Wes" Then
DocYearName = tblrow.Range.Cells(1, 37).Value
Else
DocYearName = tblrow.Range.Cells(1, 36).Value
End If
Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
With wsDst
'This copies the first 10 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
tblrow.Range.Resize(, 10).Copy
'This pastes in the figures in the first 10 columns starting in column A
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'Overwrites the numbers pasted to column I with a formula
.Range("I" & .Range("I" & .Rows.Count).End(xlUp).Row).Formula = "=IF(R[1]C[-4]=""*Activities"",0,RC[-1]*0.1)"
'Overwrites the numbers pasted to column J with a formula
.Range("J" & .Range("J" & .Rows.Count).End(xlUp).Row).Formula = "=IF(R[1]C[-5]=""*Activities"",RC[-2],RC[-1]+RC[-2])"
Rows("3:1000").Select
Workbooks(DocYearName).Worksheets(Combo).Sort.SortFields.Clear
Workbooks(DocYearName).Worksheets(Combo).Sort.SortFields.Add Key:=Range("A4:A1000"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Workbooks(DocYearName).Worksheets(Combo).Sort
.SetRange Range("A3:AJ1000")
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Next tblrow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have been trying to work this out al morning but I just can't seem to get it. Nothing I try seems to work and I need some help please.
As I have mentioned, the code above works for when the wb is open but the quote may have parts relevant to about 10 years in the future. As they are financial years, I don't want to have to have 10 yearly documents open. I have code above that checks the date of every row in the table and pastes the row at the bottom of the relevant wb. I need code that checks to see if it is already open, and if it is, complete the copying procedure, but if it isn't open, I need code to open the wb, paste the row at the bottom of the list, sort them by date, save it then close the wb.
Any help would be greatly appreciated!
Dave