Macro Does Not Close Excel Workbook

[legalhustler]

Hello,

The following macro copies a sheet (called "Data") from a Source workbook to a Destination workbook (both on SharePoint). When the procedure executes, the sheet is copied from the Source workbook to the Destination workbook and the Destination workbook saves & closes but then after a few second the Source workbook opens (in read only) and asks if I want to Save it after I click the X on the top right corner of the workbook. The Source workbook like the Destination workbook should NOT open after the macro finishes and I do not want any changes saved to it. I do not want the Excel application to close because I may have other workbooks open, just the two workbooks should close. Can anyone help modify the code below?

Additionally, if the macro is run more than once I would like the sheet that is copied (i.e. sheet name "Data 4.18.2024") to be replaced with the current version and renamed accordingly (i.e. sheet name "Data 4.18.2024"). I was hoping the part of the code where the comment is "Check if table with the same name exists, delete it if found" would do that but it does not. Can this also be corrected?

Sub PasteDataToLastWorksheet()
    Dim sourceWorkbookPath As String
    Dim destinationWorkbookPath As String
    Dim sourceWorkbook As Workbook
    Dim destinationWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim currentDate As String
    Dim sourceTable As ListObject
    Dim destinationTable As ListObject
    Dim sourceHeaderRow As Range
    Dim destinationHeaderRow As Range
    Dim destinationStartCell As Range
    Dim sourceDataRange As Range
    Dim sourceTableRange As Range
 
    ' Turn off screen updating to speed up the macro and prevent flickering
    Application.ScreenUpdating = False
 
    ' Define paths for source and destination workbooks
    sourceWorkbookPath = "https://.sharepoint.com/sites/DailyOrders?web=1"
    destinationWorkbookPath = "https://.sharepoint.com/sites/DailyOrders.xlsm?web=1"
 
    ' Open source workbook in read-only mode
    Set sourceWorkbook = Workbooks.Open(Filename:=sourceWorkbookPath, ReadOnly:=True)
    Set sourceSheet = sourceWorkbook.Sheets("Data")
 
    ' Get reference to source table and its header row
    Set sourceTable = sourceSheet.ListObjects("Data")
    Set sourceHeaderRow = sourceTable.HeaderRowRange
 
    ' Remove filters from source table
    sourceTable.AutoFilter.ShowAllData
 
    ' Get current date
    currentDate = Format(Now, "m.d.yyyy")
 
    ' Open destination workbook
    Workbooks.Open destinationWorkbookPath
    Set destinationWorkbook = Workbooks("DailyOrders.xlsm")
 
    ' Check if table with the same name exists, delete it if found
    For Each destinationSheet In destinationWorkbook.Sheets
        For Each destinationTable In destinationSheet.ListObjects
            If destinationTable.Name = "Data" Then
                Application.DisplayAlerts = False
                destinationTable.Delete
                Application.DisplayAlerts = True
                Exit For
            End If
        Next destinationTable
    Next destinationSheet
 
    ' Copy source table data including header row
    Set sourceTable = sourceSheet.ListObjects("Data")
    Set sourceHeaderRow = sourceTable.HeaderRowRange
    Set sourceDataRange = sourceTable.DataBodyRange
    Set sourceTableRange = Union(sourceHeaderRow, sourceDataRange)
    sourceTableRange.Copy
 
    ' Paste data into destination workbook
    Dim lastSheet As Worksheet
    Set lastSheet = destinationWorkbook.Sheets(destinationWorkbook.Sheets.Count)
    Set destinationSheet = destinationWorkbook.Sheets.Add(After:=lastSheet)
    destinationSheet.Name = "Data " & currentDate
    Set destinationStartCell = destinationSheet.Range("A1")
    destinationStartCell.PasteSpecial Paste:=xlPasteValues
    Set destinationTable = destinationSheet.ListObjects.Add(xlSrcRange, destinationStartCell.CurrentRegion, , xlYes)
    Set destinationHeaderRow = destinationTable.HeaderRowRange
    destinationHeaderRow.Value = sourceHeaderRow.Value
    Application.CutCopyMode = False
 
    ' Save changes in destination workbook
    destinationWorkbook.Save
    destinationWorkbook.Close
 
    ' Close source workbook without saving changes and hide it
    sourceWorkbook.Close SaveChanges:=False
 
    ' Turn on screen updating
    Application.ScreenUpdating = True
End Sub

 

[legalhustler]

If your macro is in your destination WB then what is this? It looks like your code is not in your destination WB. If that is the case, then that change won't have any affect

' Open destination workbook
    Workbooks.Open destinationWorkbookPath
    Set destinationWorkbook = Workbooks("DailyOrders.xlsm")

DELETED

 

[legalhustler]

If your macro is in your destination WB then what is this? It looks like your code is not in your destination WB. If that is the case, then that change won't have any affect

' Open destination workbook
    Workbooks.Open destinationWorkbookPath
    Set destinationWorkbook = Workbooks("DailyOrders.xlsm")

I see. I commented that part so it does not run along with the "Check if table with the same name exists, delete it if found" part then got a debug error on the line "Set lastSheet = destinationWorkbook.Sheets(destinationWorkbook.Sheets.Count)" not sure what I need to do. How would I change the code so that it runs from the destination workbook?

Sub PasteDataToLastWorksheet()
    Dim sourceWorkbookPath As String
    Dim destinationWorkbookPath As String
    Dim sourceWorkbook As Workbook
    Dim destinationWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim currentDate As String
    Dim sourceTable As ListObject
    Dim destinationTable As ListObject
    Dim sourceHeaderRow As Range
    Dim destinationHeaderRow As Range
    Dim destinationStartCell As Range
    Dim sourceDataRange As Range
    Dim sourceTableRange As Range
 
    ' Turn off screen updating to speed up the macro and prevent flickering
    Application.ScreenUpdating = False
 
    ' Define paths for source and destination workbooks
    sourceWorkbookPath = "https://.sharepoint.com/sites/DailyOrders?web=1"
    destinationWorkbookPath = "https://.sharepoint.com/sites/DailyOrders.xlsm?web=1"
 
    ' Open source workbook in read-only mode
    Set sourceWorkbook = Workbooks.Open(Filename:=sourceWorkbookPath, ReadOnly:=True)
    Set sourceSheet = sourceWorkbook.Sheets("Data")
 
    ' Get reference to source table and its header row
    Set sourceTable = sourceSheet.ListObjects("Data")
    Set sourceHeaderRow = sourceTable.HeaderRowRange
 
    ' Remove filters from source table
    sourceTable.AutoFilter.ShowAllData
 
    ' Get current date
    currentDate = Format(Now, "m.d.yyyy")
 
    ' Open destination workbook
    'Workbooks.Open destinationWorkbookPath
    'Set destinationWorkbook = Workbooks("DailyOrders.xlsm")
 
    ' Check if table with the same name exists, delete it if found
   ' For Each destinationSheet In destinationWorkbook.Sheets
        'For Each destinationTable In destinationSheet.ListObjects
            'If destinationTable.Name = "Data" Then
               ' Application.DisplayAlerts = False
                'destinationTable.Delete
               ' Application.DisplayAlerts = True
                'Exit For
            'End If
        'Next destinationTable
    'Next destinationSheet
 
    ' Copy source table data including header row
    Set sourceTable = sourceSheet.ListObjects("Data")
    Set sourceHeaderRow = sourceTable.HeaderRowRange
    Set sourceDataRange = sourceTable.DataBodyRange
    Set sourceTableRange = Union(sourceHeaderRow, sourceDataRange)
    sourceTableRange.Copy
 
    ' Paste data into destination workbook
    Dim lastSheet As Worksheet
    Set lastSheet = destinationWorkbook.Sheets(destinationWorkbook.Sheets.Count)
    Set destinationSheet = destinationWorkbook.Sheets.Add(After:=lastSheet)
    destinationSheet.Name = "Data " & currentDate
    Set destinationStartCell = destinationSheet.Range("A1")
    destinationStartCell.PasteSpecial Paste:=xlPasteValues
    Set destinationTable = destinationSheet.ListObjects.Add(xlSrcRange, destinationStartCell.CurrentRegion, , xlYes)
    Set destinationHeaderRow = destinationTable.HeaderRowRange
    destinationHeaderRow.Value = sourceHeaderRow.Value
    Application.CutCopyMode = False
 
     ' Close source workbook without saving changes and hide it
    sourceWorkbook.Close SaveChanges:=False
 
    ' Turn on screen updating
    Application.ScreenUpdating = True

' Save changes in destination workbook
    destinationWorkbook.Save
    destinationWorkbook.Close
End Sub

 

[Jeffrey Mahoney]

I would put this macro in the Destination WB and run it from there. You'll need to add the code below. Then I have to ask if you want to close it at the end or just let you, the user, save and close it.

Set destinationWorkbook = Thisworkbook

 

[legalhustler]

I would put this macro in the Destination WB and run it from there. You'll need to add the code below. Then I have to ask if you want to close it at the end or just let you, the user, save and close it.

Set destinationWorkbook = Thisworkbook

Yes, the macro should be in the destination WB. When the procedure finishes running, I want the destination WB saved and closed, I do not want the source WB saved nor opened. Can you provide the entire updated code to reflect that?

 

[Jeffrey Mahoney]

You were almost there, all you had to do was add that last line I mentioned above. Here's the full code. There is a VERY complicated way to get data from another WB without opening it, but I doubt it would work on a Sharepoint location, and it's too much trouble. You have to open the source to get data out of the source. The code to open it as read only and close it without saving is already in the code.

Remember, this code has to be in the destination WB.

Sub PasteDataToLastWorksheet()
    Dim sourceWorkbookPath As String
    Dim destinationWorkbookPath As String
    Dim sourceWorkbook As Workbook
    Dim destinationWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim currentDate As String
    Dim sourceTable As ListObject
    Dim destinationTable As ListObject
    Dim sourceHeaderRow As Range
    Dim destinationHeaderRow As Range
    Dim destinationStartCell As Range
    Dim sourceDataRange As Range
    Dim sourceTableRange As Range
 
    ' Turn off screen updating to speed up the macro and prevent flickering
    Application.ScreenUpdating = False
 
    ' Define paths for source and destination workbooks
    sourceWorkbookPath = "https://.sharepoint.com/sites/DailyOrders?web=1"
    destinationWorkbookPath = "https://.sharepoint.com/sites/DailyOrders.xlsm?web=1"
 
    ' Open source workbook in read-only mode
    Set sourceWorkbook = Workbooks.Open(Filename:=sourceWorkbookPath, ReadOnly:=True)
    Set sourceSheet = sourceWorkbook.Sheets("Data")
 
    ' Get reference to source table and its header row
    Set sourceTable = sourceSheet.ListObjects("Data")
    Set sourceHeaderRow = sourceTable.HeaderRowRange
 
    ' Remove filters from source table
    sourceTable.AutoFilter.ShowAllData
 
    ' Get current date
    currentDate = Format(Now, "m.d.yyyy")
 
    ' destination workbook ALREADY OPEN
    Set destinationWorkbook = ThisWorkbook
 
    ' Check if table with the same name exists, delete it if found
    For Each destinationSheet In destinationWorkbook.Sheets
        For Each destinationTable In destinationSheet.ListObjects
            If destinationTable.Name = "Data" Then
                Application.DisplayAlerts = False
                destinationTable.Delete
                Application.DisplayAlerts = True
                Exit For
            End If
        Next destinationTable
    Next destinationSheet
 
    ' Copy source table data including header row
    Set sourceTable = sourceSheet.ListObjects("Data")
    Set sourceHeaderRow = sourceTable.HeaderRowRange
    Set sourceDataRange = sourceTable.DataBodyRange
    Set sourceTableRange = Union(sourceHeaderRow, sourceDataRange)
    sourceTableRange.Copy
 
    ' Paste data into destination workbook
    Dim lastSheet As Worksheet
    Set lastSheet = destinationWorkbook.Sheets(destinationWorkbook.Sheets.Count)
    Set destinationSheet = destinationWorkbook.Sheets.Add(After:=lastSheet)
    destinationSheet.Name = "Data " & currentDate
    Set destinationStartCell = destinationSheet.Range("A1")
    destinationStartCell.PasteSpecial Paste:=xlPasteValues
    Set destinationTable = destinationSheet.ListObjects.Add(xlSrcRange, destinationStartCell.CurrentRegion, , xlYes)
    Set destinationHeaderRow = destinationTable.HeaderRowRange
    destinationHeaderRow.Value = sourceHeaderRow.Value
    Application.CutCopyMode = False
 
     ' Close source workbook without saving changes and hide it
    sourceWorkbook.Close SaveChanges:=False
 
    ' Turn on screen updating
    Application.ScreenUpdating = True

' Save changes in destination workbook
    destinationWorkbook.Save
    destinationWorkbook.Close
End Sub