I need code to open a wb, do an operation then close it

dpaton05

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

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
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
I played around with the code and now when I try and run it, I get the error message "unable to get the sort property of the range class".

This is my code
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 ActiveCell.EntireRow.Cells(1, 6).Value = "Anglicare Western" Then
            If tblrow.Range.Cells(1, 6).Value = "Anglicare Western" Then
                DocYearName = tblrow.Range.Cells(1, 37).Value
            Else
                DocYearName = tblrow.Range.Cells(1, 36).Value
            End If
            'To open the workbook stored in the variable DocYearName
            Workbooks.Open Filename:=ThisWorkbook.Path & "\" & DocYearName
            
            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])"
                   
                End With
                                                

        Next tblrow
            
              Workbooks(DocYearName).Worksheets(Combo).Rows("3:1000").Sort.SortFields.Clear 'Sort rows based on date
                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
                        
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
End Sub

I wasn't sure how to write the sort code at the end.

Thanks,
Dave
 
Upvote 0

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

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