Hi to all.
This macro was created in 2010 with excel 2000 and it worked with xls.
Now I changed with save as xlsm but there is an error here:
=======================================================
wsOri.Copy before:=wbDest.Sheets(1) 'errore qui se questo workbook è in formato XLSM
Set wsDest = wbDest.ActiveSheet
wsDest.Unprotect "123456"
'=======================================================
the error is this:
(translated with google translator)
1004 run-time error
impossible to insert the sheets in the destination workbook because
contains fewer rows and columns than the
work of origin. To move or copy data in the workbook of
destination, you can select them, then in the sheets of another
workbook using the Copy and Paste commands
the macro:
an aid to correct?
max_max
This macro was created in 2010 with excel 2000 and it worked with xls.
Now I changed with save as xlsm but there is an error here:
=======================================================
wsOri.Copy before:=wbDest.Sheets(1) 'errore qui se questo workbook è in formato XLSM
Set wsDest = wbDest.ActiveSheet
wsDest.Unprotect "123456"
'=======================================================
the error is this:
(translated with google translator)
1004 run-time error
impossible to insert the sheets in the destination workbook because
contains fewer rows and columns than the
work of origin. To move or copy data in the workbook of
destination, you can select them, then in the sheets of another
workbook using the Copy and Paste commands
the macro:
Code:
Sub CopiaESalvaInPathX()
'-----------------------------------------------------------------------------------------
'avviso all'avvio
Dim avviso As String
'avviso = MsgBox("Sign. " & Environ("UserName") & " salvo il modulo?" _
'& Chr(13) & "" _
'& Chr(13) & "attenzione:", _
'vbQuestion + vbYesNo + vbDefaultButton2, "xxxxxxxxxxxxxx")
avviso = MsgBox("Sign. " & Environ("UserName") & " save sheet?" _
& Chr(13) & "" _
& Chr(13) & "attention:", _
vbQuestion + vbYesNo + vbDefaultButton2, "xxxxxxxxxxxxxx")
If avviso = 7 Then
ActiveSheet.Protect "123456"
Exit Sub
End If
If ActiveSheet.Range("Q2") = "" Or ActiveSheet.Range("T2") = "" Then
'avviso = MsgBox("Sign. " & Environ("UserName") & "" _
'& Chr(13) & "non hai inserito il nome del CLIENTE/COMMESSA!", _
'vbCritical, "xxxxxxxxxxxxxxxxxx")
avviso = MsgBox("Sign. " & Environ("UserName") & "" _
& Chr(13) & "name name1/name2", _
vbCritical, "attention")
'If avviso = 7 Then
'ActiveSheet.Protect "123456"
Exit Sub
End If
'-----------------------------------------------------------------------------------------
'dichiarazioni delle variabili
Dim wbOri As Workbook
Dim wsOri As Worksheet
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim sh As Worksheet
Dim sPath As String
Dim sComm1, sComm2, sComm3, sComm4, sComm5, sComm6, sComm7 As String
Dim sWS As String
Dim sWB As String
Dim sData As String
Dim sNomeFile As String
Dim nSfx As Long
Dim nFogliNew As Long
Dim oShp As Shape
Dim savechanges As Long
Dim FSO As Object
Dim shp As Shape
Dim testStr As String
Dim estensione As String
'Const xlExcel8 As Long = 56
'Const xlOpenXMLWorkbook As Long = 51
'-------------------------------------------------------------------------------------
'per visualizzare errori
On Error GoTo gest_err
'-------------------------------------------------------------------------------------
'impostazioni applicazione
With Application
.DisplayAlerts = False
.ScreenUpdating = False
nFogliNew = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.EnableEvents = False '<<< aggiunto
End With
'-------------------------------------------------------------------------------------
'set degli oggetti
Set wbOri = ThisWorkbook
Set wsOri = wbOri.ActiveSheet
Set wbDest = Application.Workbooks.Add
sWS = wsOri.Name
'-----------------------------------------------------------------------------------------
'indirizzo path di salvataggio
sComm4 = wsOri.Range("Q2").Value '<<< cartella nome cella
sComm5 = wsOri.Range("T2").Value '<<< cartella nome cella
sComm6 = sComm4 & "-" & sComm5 '<<< cartella nome cella
'sPath = "C:\Users\massimo\Desktop\moduli_salvati\" & sComm6 'casa_new
'sPath = "J:\xxxxxxxxxxxxxxxxxxx\" & sComm6 'ufficio cartella comune
sPath = "C:\Users\xxxxxxxx\Desktop\moduli_salvati\" & sComm6 '<<<<< new prova
'---------------------------------------------------
'crea in automatico cartella
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(sPath) Then
FSO.CreateFolder sPath
End If
'---------------------------------------------------
'---------------------------------------------------------------------------------------
'nomi celle nel nome di salvataggio
sComm1 = wsOri.Range("C3").Value
sComm2 = wsOri.Range("C4").Value
sComm3 = wsOri.Range("G4").Value
sData = Format(Date, "dd-mm-yyyy")
sWB = "MOD_FAL. COMM. " & sComm1 & " - " & sComm2 & " - " & sComm3 & " (" & sData & ")"
'--------------------------------------------------------------------------------------
'=========================================================================================
wsOri.Copy before:=wbDest.Sheets(1) 'errore qui se questo workbook è in formato XLSM
Set wsDest = wbDest.ActiveSheet
'wsDest.Unprotect "123456"
'=========================================================================================
'=========================================================================================
'togliere l'istruzione successiva se il foglio salvato non deve essere protetto
'wsDest.Protect "123456"
'-------------------------------------------------------------------------------------------
'per fermarsi nella cella del foglio salvato
Range("C3").Select
'Application.Goto Reference:=Range("C3"), scroll:=True
'-------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------
sPath = sPath & "\" & sWS
For Each sh In wbDest.Sheets
If sh.Name <> wsDest.Name Then
sh.Delete
End If
Next
'-------------------------------------------------------------------------------------
'controllo/creazione dir da nome foglio
If Dir(sPath, vbDirectory) = vbNullString Then
MkDir (sPath)
End If
'--------------------------------------------------------------------------------------
'loop per creazione nome file progressivo
Do
nSfx = nSfx + 1
'--------------------------------------------------------------------------------------
'estensione salvataggio
'estensione = ".xls" ' oppure xlsx
estensione = ".xlsx" ' oppure xls
sNomeFile = sPath & "\" & sWB & " - " & nSfx & estensione 'con numero progressivo
'sNomeFile = sPath & "\" & sWB & estensione 'senza numero progressivo
'--------------------------------------------------------------------------------------
'loop per creazione nome file progressivo
Loop While Dir(sNomeFile) <> vbNullString
'--------------------------------------------------------------------------------------
'estensione salvataggio
'If estensione = ".xls" Then
'If Val(Application.Version) < 12 Then
'ActiveWorkbook.SaveAs Filename:=sNomeFile
'Else
'ActiveWorkbook.SaveAs Filename:=sNomeFile, FileFormat:=xlExcel8
'End If
'Else
ActiveWorkbook.SaveAs Filename:=sNomeFile, FileFormat:=xlOpenXMLWorkbook '<<< per formato xslx
'End If
'--------------------------------------------------------------------------------------
'se si vuole non si vuole visualizzare il nuovo file togliere l'istruzione successiva (togliere Option Explicit)
wbDest.Close savechanges = True
'--------------------------------------------------------------------------------------
'per visualizzare errori
gest_err:
If Err.Number <> 0 Then
MsgBox "Errore " & Err.Number & ": " & Err.Description, vbCritical, "Errore"
End If
'--------------------------------------------------------------------------------------
Set wsOri = Nothing
Set wbOri = Nothing
Set wsDest = Nothing
Set wbDest = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.SheetsInNewWorkbook = nFogliNew
.EnableEvents = True
End With
Application.ScreenUpdating = True
'End If
End Suban aid to correct?
max_max
