runtime error "1004' Command is not available in a shared workbook

[bigpappi23]

Hi guy,

i have this code for copying diffrent ranges of cells and saving it in different workbooks:

Sub NewCopy()

Dim strFileName As String
Dim range1 As Range
Dim rng1 As Range, rng2 As Range, myMultiRanges As Range
Worksheets("ACL & History").Activate
Set rng1 = Range("A1:E7")
Set rng2 = Range("A80:E86")
Set myMultiRanges = Union(rng1, rng2)
myMultiRanges.Select


strFileName = InputBox("Type a name for the new workbok", "File Name")
If Trim(strFileName) = vbNullString Then Exit Sub

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Selection.Copy
Sheets.Add.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Move
ActiveWorkbook.SaveAs "C:\Users\zztongl\" & strFileName & ".xlsm", xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close False

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub



the problem is when is share the workbook, it generated the runtime error '1004' Command is not available in a shared workbook...can anyone help me to make it work even in a shared workbook.



thanks in advance guys,
this forum really helped me with my vba questions

 

[sgmpatnaik]

@bigpappi

Hi

You can't move the sheet in shared workbook

with your code please remove the line

Activesheet.Move

changed code is

Sub NewCopy()
    
    Dim strFileName As String
    Dim range1 As Range
    Dim rng1 As Range, rng2 As Range, myMultiRanges As Range
    Worksheets("ACL & History").Activate
    Set rng1 = Range("A1:E7")
    Set rng2 = Range("A80:E86")
    Set myMultiRanges = Union(rng1, rng2)
    myMultiRanges.Select

   
    strFileName = InputBox("Type a name for the new workbok", "File Name")
    If Trim(strFileName) = vbNullString Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Selection.Copy
    Sheets.Add.Range("A1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
    ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveWorkbook.SaveAs "C:\Users\zztongl\" & strFileName & ".xlsm", xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close False
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Hope it will solve your problem other wise please inform

Thanks

Patnaik

 

[bigpappi23]

@sgmpatnaik

Hi

the code works in a shared workbook but it copies all the worksheet. i just want to copy the selection

thanks,

 

[sgmpatnaik]

@bigpappi23

sorry for my late replay just i was busy with my work, please try the below code

Sub NewCopy()
Dim strFileName As String

Dim rng1 As Range, rng2 As Range, myMultiRanges As Range
Dim wbDest As Workbook

Worksheets("ACL & History").Activate

Set rng1 = Range("A1:E7")
Set rng2 = Range("A80:E86")
Set myMultiRanges = Union(rng1, rng2)

strFileName = InputBox("Type a name for the new workbok", "File Name")
If Trim(strFileName) = vbNullString Then Exit Sub

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set wbDest = Workbooks.Add

With wbDest
    With .Sheets("Sheet1")
        myMultiRanges.Copy .Range("A1")
        .UsedRange.EntireColumn.AutoFit
    End With
    .SaveAs "C:\Users\zztong1\" & strFileName & ".xlsx", xlOpenXMLWorkbook
    .Close
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

If any problem please refer us

Thanks

Patnaik