macro to disconnect data connections when copying a sheet from master to standalone wrkbk

[ansvk1]

Hi there,
I have a code for creating a separate worksheet for any active sheet out of a master workbook that has data connections in it. now i am looking for a way to insert macro code that can:

1. make sure this new workbook being created is matching the original format
2. disconnecting all the data connections and bringing only values for those connections

Here is my code:

Sub Button1_Click()


    Dim ws As Worksheet
    Dim wbNew As Excel.Workbook, wbCurrent As Excel.Workbook
    Dim strFileName As String


    'Assign object variables
    Set wbCurrent = ActiveWorkbook
    Set ws = wbCurrent.ActiveSheet


    'Get desired file path from user
    strFileName = InputBox("Enter File Name: ", "Creating New File...")
    If strFileName <> "" Then
        
    'copy whole current sheet but with format intact & disconneting data connections, while bringing just their values over
        ws.Copy
        myFileName = wbCurrent.Path & "\" & strFileName & ".xlsx"
        ActiveWorkbook.SaveAs wbCurrent.Path & "\" & strFileName
    End If
End Sub

thanks for your help!

 

[JackDanIce]

Try:

Sub Button1_Click()

    Dim x       As Long
    Dim y       As Long
    Dim strFile As String
    Dim strName As String
    Dim wks     As Worksheet
    Dim rng     As Range
    
    strFile = InputBox("Enter file name: ", "Creating New File")
    If strFile = "" Then Exit Sub
    
    Set wks = ActiveSheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


     With wks
        strName = .Name
        x = .Cells(.Rows.count, 1).End(xlUp).row
        y = .Cells(Columns.count, 1).End(xlToLeft).column
        Set rng = .Cells(1, 1).Resize(x, y)
    End With
    
    Set wks = Worksheets.add(after:=Sheets.count)
        .Cells(1, 1).Resize(x, y).Value = rng.Value
        rng.Copy
        .Cells(1, 1).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
    End With
        
    With Workbooks.add
        wks.Move before:=.Sheets(1)
        .Sheets(1).Name = strName
    End With
    
    ActiveWorkbook.SaveAs ThisWorkbook.path & "\" & strFile & ".xlsx"
    
    ThisWorkbook.Sheets(Worksheets.count).Delete
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

 

[ansvk1]

Thanks Jack!
when i tried to run it, first thing happened is, i got a compile error: Invalid or unqualified reference (when clicked ok). it took me to Ln 29, Col 15 (.Cells)
Please advise!

 

[JackDanIce]

Try:

Sub Button1_Click()

    Dim x       As Long
    Dim y       As Long
    Dim strFile As String
    Dim strName As String
    Dim wks     As Worksheet
    Dim rng     As Range
    
    strFile = InputBox("Enter file name: ", "Creating New File")
    If strFile = "" Then Exit Sub
    
    Set wks = ActiveSheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

     With wks
        strName = .Name
        x = .Cells(.Rows.count, 1).End(xlUp).row
        y = .Cells(Columns.count, 1).End(xlToLeft).column
        Set rng = .Cells(1, 1).Resize(x, y)
    End With
    
    Set wks = Worksheets.add(after:=Sheets.count)
    With wks
        .Cells(1, 1).Resize(x, y).Value = rng.Value
        rng.Copy
        .Cells(1, 1).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
    End With
        
    With Workbooks.add
        wks.Move before:=.Sheets(1)
        .Sheets(1).Name = strName
    End With
    
    ActiveWorkbook.SaveAs ThisWorkbook.path & "\" & strFile & ".xlsx"
    
    ThisWorkbook.Sheets(Worksheets.count).Delete
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

 

[ansvk1]

tried it, says" Run-time error '1004': Method'Add' of object 'Sheets' failed.
on Ln27, col 1

 

[JackDanIce]

Sub Button1_Click()

    Dim x       As Long
    Dim y       As Long
    Dim strFile As String
    Dim strName As String
    Dim wks     As Worksheet
    Dim rng     As Range
    
    strFile = InputBox("Enter file name: ", "Creating New File")
    If strFile = "" Then Exit Sub
    
    Set wks = ActiveSheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

     With wks
        strName = .Name
        x = .Cells(.Rows.count, 1).End(xlUp).row
        y = .Cells(Columns.count, 1).End(xlToLeft).column
        Set rng = .Cells(1, 1).Resize(x, y)
    End With
    
    Set wks = Worksheets.add(after:=Worksheets(Sheets.count))
    With wks
        .Cells(1, 1).Resize(x, y).Value = rng.Value
        rng.Copy
        .Cells(1, 1).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
    End With
        
    With Workbooks.add
        wks.Move before:=ActiveWorkbook.Sheets(1)
        .Sheets(1).Name = strName
    End With
    
    ActiveWorkbook.SaveAs ThisWorkbook.path & "\" & strFile & ".xlsx"
    
    ThisWorkbook.Sheets(Worksheets.count).Delete
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

 

[ansvk1]

thanks Jack!
code ran through fine. But, here are the things it did not get quite correctly.
1. the format is not being carried over the same. org sht had part of column in orange accent (R252,G228,B214) while the copied sht had Grey accent (R237,G237,B237)
2. Yes, it doesn't have any data connections

is there a way to: just copy the whole sht as it is, with exact column widths and row heights, and colors.

 

[JackDanIce]

Try:

Sub Button1_Click()


    Dim x       As Long
    Dim y       As Long
    Dim strFile As String
    Dim strName As String
    Dim wks     As Worksheet
    
    strFile = InputBox("Enter file name: ", "Creating New File")
    If strFile = "" Then Exit Sub
    
    Set wks = ActiveSheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


     With wks
        strName = .Name
        x = .Cells(.Rows.count, 1).End(xlUp).row
        y = .Cells(Columns.count, 1).End(xlToLeft).column
        .Copy
    End With
                        
    With ActiveWorkbook
        .ActiveSheet.Cells(1, 1).Resize(x, y).Value = .ActiveSheet.Cells(1, 1).Resize(x, y).Value
        .SaveAs ThisWorkbook.path & "\" & strFile & ".xlsx"
    End With
    
    ThisWorkbook.Sheets(Worksheets.count).Delete
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With


End Sub

 

[ansvk1]

got application defined or object defined error on LN27

 

[JackDanIce]

This ran for me fine with out error and created a separate workbook with user name for the activesheet:

Sub Button1_Click()

    Dim x       As Long
    Dim y       As Long
    Dim strFile As String
    Dim strName As String
    Dim wks     As Worksheet
    
    strFile = InputBox("Enter file name: ", "Creating New File")
    If strFile = "" Then Exit Sub
    
    Set wks = ActiveSheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


     With wks
        strName = .Name
        x = .Cells(.Rows.count, 1).End(xlUp).row
        y = .Cells(Columns.count, 1).End(xlToLeft).column
        .Copy
    End With
                        
    With ActiveWorkbook
        .ActiveSheet.Cells(1, 1).Resize(x, y).Value = .ActiveSheet.Cells(1, 1).Resize(x, y).Value
        .SaveAs ThisWorkbook.path & "\" & strFile & ".xlsx"
    End With
    
    ThisWorkbook.Sheets(Worksheets.count).Delete
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub