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?

 

[Michael M]

The sheets are blank, because no information has been transferred....so I can't tell why the last row doesn't get sorted !!
Does the problem regardless of the month ??

Maybe you need to isnert soem code to makes sure the rows are complete before transferring the data.
Something like this for the WsDst sheet, like you used on the tblrows

            If Cells(1, 1).Value = "" Or Cells(1, 5).Value = "" Or Cells(1, 6).Value = "" Then
                MsgBox "Records are incomplete and cannot be transferred"
                Exit Sub
            End If

 

[dpaton05]

All you need to do is put the allocation sheets in the same folder as the quoting tool, enter a few quotes with dates in the same month, in npss_quote that are not in order, copy them to the costing tool several times then try and copy them to the allocation sheets. If they are all in the one month, you should notice that they all are sorted except the final row.

Thanks for helping me Michael,
Dave

 

[Michael M]

Yeah, I know what NEEDS to be done....but if it then works for me, we haven't achieved anything !!
I want to see a sheet that has not worked for you !!

 

[dpaton05]

Sorry Michael, I didn't understand your question but I do now. I will get one to you as soon as possible.

 

[MARK858]

@dpaton05, just out of interest what happens if you change the line

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

to

lr = wsDst.Columns("A:J").Find("*", , xlValues, , xlByRows, xlPrevious).Row

 

[MARK858]

Oops, sorry Michael I missed the post where you suggested similar to post 35

Back to post 33 then

 

[dpaton05]

Hi Michael, I think I have found the problem.

1. If I delete a row using the delete all lines button in npss_quote, it doesn't fully sort the allocation sheet if I then add a line under it then fill it out. Also, I am not prompted if I enter a earlier date than today if I then try to enter a date in the row I deleted.
2. If I delete one or more lines using the "delete all lines button", the allocation sheet is successfully sorted following the adding of more rows underneath it and I am prompted as described above if I enter a date in the row.
3. If it is working and I select Add Line, it will add a line that will ask for prompting if the date is before today and will sort the allocation sheet.

I think it is the code for deleting the row on the sheet, npss_quote_sheet. As mentioned above, it will work if I select cmdDeleteRow, then select cmdAddRow, and fill it out, but will not work if select the cmdDeleteQuoteLines then select cmdAddRow again.

Could you help me update the code in cmdDeleteQuoteLines so it reflects the method used in cmdDeleteRow please?

My add line button has the following code:

Private Sub cmdAddRow_Click()
ActiveSheet.Unprotect Password:="npssadmin"
Application.EnableEvents = False
'ActiveSheet.Protect Password:="npssadmin"

Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects("npss_quote")
'add a row at the end of the table
tbl.ListRows.Add
    ListObjects("NPSS_quote").ListColumns("10%Increase").DataBodyRange.Value = "1"



'ActiveSheet.Protect Password:="npssadmin"
Application.EnableEvents = True
End Sub

cmdDeleteQuoteLines has this code:

Private Sub cmdDeleteQuoteLines_Click()
Application.EnableEvents = False
    'Deleting The Data In A Table
    Dim tbl As ListObject
    Dim cell As Range
    
    Set tbl = Sheets("NPSS_quote_sheet").ListObjects("npss_quote")
    'Delete all table rows except first row
    With tbl.DataBodyRange
        If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End If
        'Clear the contents, but not delete the formulas
        For Each cell In tbl.ListRows(1).Range.Cells
            If Not cell.HasFormula Then
                cell.Value = ""
            End If
        Next
    End With
Application.EnableEvents = True
End Sub

cmdDeleteRow has the following code:

Private Sub cmdDeleteRow_Click()
ActiveSheet.Unprotect Password:="npssadmin"
Application.EnableEvents = False

   Dim ans As Long
    With ActiveSheet.ListObjects("npss_quote").DataBodyRange
        ans = .Rows.Count
        If ans = 0 Then Exit Sub
        If ans > 1 Then .Rows(ans).Delete
        If ans = 1 Then .Rows(1).Cells.SpecialCells(xlCellTypeConstants).ClearContents
    End With

    'Selection.ListObject.ListRows(6).Delete
    ListObjects("NPSS_quote").ListColumns("10%Increase").DataBodyRange.Value = "1"

Application.EnableEvents = True

'ActiveSheet.Protect Password:="npssadmin"
End Sub

In case you need the workbook, I have uploaded the workbook with the above code in it if you need to check anything or there is something that I have not explained. Just need help with the delete code in cmdDeleteQuoteLines.

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


Thanks Michael,
Dave

 

[MARK858]

Ok without reading everything back or testing what happens with

lr = wsDst.Columns("A:J").Find("*", , xlFormulas, , xlByRows, xlPrevious).Row

 

[dpaton05]

Not sure where to put that code but all I want mark is to have the method used to delete a row in cmdDeleteRow

Private Sub cmdDeleteRow_Click()ActiveSheet.Unprotect Password:="npssadmin"
Application.EnableEvents = False


   Dim ans As Long
    With ActiveSheet.ListObjects("npss_quote").DataBodyRange
        ans = .Rows.Count
        If ans = 0 Then Exit Sub
        If ans > 1 Then .Rows(ans).Delete
        If ans = 1 Then .Rows(1).Cells.SpecialCells(xlCellTypeConstants).ClearContents
    End With


    'Selection.ListObject.ListRows(6).Delete
    ListObjects("NPSS_quote").ListColumns("10%Increase").DataBodyRange.Value = "1"


Application.EnableEvents = True


'ActiveSheet.Protect Password:="npssadmin"
End Sub

used in cmdDeleteQuoteLines as well. I am just not very sure of the syntax.

Private Sub cmdDeleteQuoteLines_Click()Application.EnableEvents = False
    'Deleting The Data In A Table
    Dim tbl As ListObject
    Dim cell As Range
    
    Set tbl = Sheets("NPSS_quote_sheet").ListObjects("npss_quote")
    'Delete all table rows except first row
    With tbl.DataBodyRange
        If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
       ' Else
            '.Rows(1).Cells.SpecialCells(xlCellTypeConstants).ClearContents
        End If
        'Clear the contents, but not delete the formulas
        For Each cell In tbl.ListRows(1).Range.Cells
            If Not cell.HasFormula Then
                cell.Value = ""
            End If
        Next
    End With
Application.EnableEvents = True
End Sub

• cmdDeleteRow deletes a row from the bottom of the table
• cmdDeleteQuoteLines is meant to delete all the rows from the table but there are formulas that can't be deleted.

I have commented out a few lines of code that I tried to write but they didn't seem to work.


Thanks Mark,
Dave

 

[MARK858]

Not sure where to put that code

The same place in Michael's code that you changed lr before sigh.