Opening and closing workbooks using vba

[dpaton05]

I have a tool to calculate quotes which is in a table and can have x number of rows. Once the quote is made, I have a button to copy each row to a costing tool, which is just another sheet. Once this is done, further details can be added to the quote to finalise it. I then select a button to send it to the correct allocation sheet. These sheets are separate financial year documents and are used to keep record of the quotes.

I have code successfully does all the above tasks but it requires the allocation sheets to be open. The quote may have services that are relating to the next 10 years and my supervisor doesn't want to need to have all the allocation sheets open for that time. Therefore, I want to add code into the copy procedure that will open the workbook, copy in the row from the data then close it.

I am still learning to code so I have had to rely a lot on others.

I thought that I could add code in just before and after the copy code is run. The problem is that it is giving me all kinds of strange errors when I do this.

The variable DocYearName refers a column for the row that contains the full file name of where the quote needs to go.
The variable Combo refers to sheet within DocYearName that the quote needs to go on.

        For Each tblrow In tbl.ListRows
            Combo = tblrow.Range.Cells(1, 26).Value
                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
                    'To open the workbook stored in the variable DocYearName
                    Workbooks.Open Filename:=ThisWorkbook.Path & "\" & DocYearName
                    '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])"
                    ActiveWorkbook.Close

                                    
                End With
        Next tblrow

So it all works except when I added in the open and close lines at the start and end of the last chunk of code. The files will be all stored in the same directory.

Could someone help me please?

 

[dpaton05]

Thanks Michael. That partially works. It seems to sort everything fine except the very last row in wsDst.

 

[Michael M]

Is there content in the very last row in Column "A" ??

 

[dpaton05]

There should be as column A contains the date but there could be circumstances where they may not be date is column A, service in column E or price ex. GST in column H. However, there should be at least one of these columns for a row. Is there a way to see if there is content in one of these columns for the final row, not just one specific row (like column A for instance). So the last row should have something in one of these 3 columns.

I have not talked to my supervisor yet to see if he wants that, so could you write code for the above but also write in comments the code for if he just wants it to have the last row determined by just the date in column A please.

It is the same cell references for both source and destination workbooks, for instance, date in column A, service in column E etc.


Thanks Michael,
Dave

 

[Michael M]

Change this line

lr = wsDst.Cells(Rows.Count, "A").End(xlUp).Row

to

lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row

Sub cmdCopy()

    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    End With
        Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
        Dim Combo As String, sht As Worksheet, tbl As ListObject
        Dim LastRow As Long, lr As Long, DocYearName As String
        '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
      'For every row, set value of combo to the name of the month that contains the date of the row
            Combo = tblrow.Range.Cells(1, 26).Value
                
            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)
            [color=red]lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row[/color]
             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[0]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])"
                    'sort procedure copied from vba
                    wsDst.Sort.SortFields.Clear
                    wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            With Workbooks(DocYearName).Worksheets(Combo).Sort
                                .SetRange Range("A3:AJ" & lr)
                                .Header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With
                End With
            'save and close the workbook
            ActiveWorkbook.Save
            ActiveWorkbook.Close


        Next tblrow
   
        With Application
            .CutCopyMode = False
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
        End With
End Sub

 

[dpaton05]

The last row still seems to be not sorted. If I have multiple series of dates in npss_quote and I send them to the costing tool multiple times, all the dates get sorted within tblCosting but it still is not sorting the last row in however many rows is in the data in tblCosting, even with the new code.

 

[dpaton05]

By the way, here is my code in case you need it:

Sub cmdCopy()

    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    End With
        Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
        Dim Combo As String, sht As Worksheet, tbl As ListObject
        Dim LastRow As Long, lr As Long, DocYearName As String
        '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
    'For every row, set value of combo to the name of the month that contains the date of the row
            Combo = tblrow.Range.Cells(1, 26).Value
                
            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)
             lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
             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[0]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])"
                    'sort procedure copied from vba
                    wsDst.sort.SortFields.Clear
                    wsDst.sort.SortFields.Add Key:=Range("A4:A" & lr), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            With Workbooks(DocYearName).Worksheets(Combo).sort
                                .SetRange Range("A3:AK" & lr)
                                .header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With
                End With
            'save and close the workbook
            ActiveWorkbook.Save
            ActiveWorkbook.Close


        Next tblrow
   
        With Application
            .CutCopyMode = False
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
        End With
End Sub

Thanks Michael.

 

[Michael M]

upload the latest workbook !

 

[dpaton05]

Here you go.

https://www.dropbox.com/s/4txzvfrepkycwxg/quoting tool 10.5 WCI.xlsm?dl=0

Thanks Michael,
Dave

 

[Michael M]

Well, you are sorting by column "A" in the code...but you state that col "A" may not have data to the last row.
I guess the obvious question is.....why would you have data in other columns, without a date in Col "A"

So, you will have to either complete Col "A" with dummy data.
OR
Sort by a complete column !!

AND

the workbook you uploaded didn't give me any clue to the problem, as the sorting problem lies in the workbook......Workbooks(DocYearName).Worksheets(Combo)....NOT the Quoting_Tool workbook !

 

[dpaton05]

I agree, sorting by the date is a good idea. I have included a link to download the allocation sheets, which are where the quotes are going.

They are entered into npss_quote, copied to tblCosting where further information is entered regarding the quote. They are then copied to the relevant financial year allocation document, depending on the date of the quote. Depending on the requesting organisation selected will determine if it goes to the internal or npss allocation sheet.

The financial year documents are all the same, just with a different name. Here are the 2018-2019 allocation sheets. A different title, internal or npss and a different financial year.

https://www.dropbox.com/s/9ur2snvnm78kj40/2018 - 2019 Internal Work Allocation Sheet.xlsm?dl=0

https://www.dropbox.com/s/888j84blv82a09v/2018 - 2019 NPSS Work Allocation Sheet.xlsm?dl=0


Thanks Michael,
Dave