XL 2013 Absence de prompt enregistrement après macro

[chacal33]

Bonjour à toutes et à tous,

J'ai un classeur devis.xlsm qui récupère des données dans Access.
Puis une macro qui crée un nouveau fichier xlsm avec un nouveau nom dans un dossier différent.

Pour des raisons que je ne comprends pas, le nouveau fichier xlsm ne propose pas d'enregistrement au moment de la fermeture de ce dernier.
Il se ferme sans prendre en compte les modifications... Ce qui est très embêtant. J'ai bien vérifié que la propriété saved du fichier soit sur false, mais rien n'y fait.

Je copie-colle mon code et si vous avez des solutions, je suis preneur.

Sub DEVIS()

Sheets("REQUETE").Select

Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer

DBFullName = "Z:\POSE\DANWARE\DANWARE.accdb"

Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Connect

Dim Nbre As String
Dim Message As String, Titre As String, Defaut As String, Reponse As String
Message = "Entrez le code chantier :"
Titre = "SAISIE CODE CHANTIER"
Defaut = " "
Reponse = InputBox(Message, Titre, Defaut)
Nbre = (Reponse)
Dim Nbre1 As String
Dim Message1 As String, Titre1 As String, Defaut1 As String, Reponse1 As String
Message1 = "Entrez le code étude :"
Titre1 = "SAISIE CODE ETUDE"
Defaut1 = " "
Reponse1 = InputBox(Message1, Titre1, Defaut1)
Nbre1 = (Reponse1)

Set Recordset = New ADODB.Recordset
With Recordset
    Source = "SELECT * FROM R_ExportDevisPDG WHERE [CodeChantier] = '" & Nbre & "'"
   
    .Open Source:=Source, ActiveConnection:=Connection
   
For Col = 0 To Recordset.Fields.Count - 1
    Range("A4").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

    Range("A4").Offset(1, 0).CopyFromRecordset Recordset
End With

Set Recordset = New ADODB.Recordset
With Recordset

If Nbre1 = " " Then

    Source = "SELECT * FROM R_ExportDevisTOTAL WHERE [CodeChantier] = '" & Nbre & "'"

Else
   
    Source = "SELECT * FROM R_ExportDevisTOTAL WHERE [CodeChantier] = '" & Nbre & "' AND [DescriptionAffaire] = '" & Nbre1 & "'"
       
End If
       
    .Open Source:=Source, ActiveConnection:=Connection

For Col = 0 To Recordset.Fields.Count - 1
    Range("A8").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

    Range("A8").Offset(1, 0).CopyFromRecordset Recordset
End With

Calculate
   
    ActiveWorkbook.Save
   
    Sheets("REQUETE").Activate
   
    Application.DisplayAlerts = False
    cell1 = Range("A5").Value
    cell2 = Range("B5").Value
    cell3 = Format(Range("I1"), "yyyy-mm-dd")
    Fpath = "Z:\Secretaire\DEVIS\DEVIS PREPARES\" ' <<<< to be changed
    Fname = Fpath & "DEVIS " & cell1 & " - " & cell2 & " - " & cell3 & ".xlsm"
   
    ActiveWorkbook.SaveCopyAs Filename:=Fname

    Workbooks.Open Filename:=Fname
   
    ActiveWorkbook.Save
      
    Sheets("REQUETE").Select
    Dim lastrow As Long
    lastrow = Cells(Rows.Count, 2).End(xlUp).Row
    Range("A9:K" & lastrow).Sort key1:=Range("E9:E" & lastrow), order1:=xlAscending, Header:=xlNo
      
    Sheets("PdeG").Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("OFFRE").Select
    Columns("A:E").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("M:M").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F7").Select
    ActiveCell.FormulaR1C1 = "=+RC[-1]*RC[-2]"
    Range("F7").Select
    Selection.Copy
    Range("F7:F96").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("F98").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=SUM(R[-91]C:R[-1]C)"
    Range("F100").Select
    ActiveCell.FormulaR1C1 = "=+R[-1]C*0.2"
    Range("F103").Select
    ActiveCell.FormulaR1C1 = "=+R[-3]C+R[-5]C"
    Range("F104").Select

Dim i As Integer
For i = 95 To 7 Step -2

If Cells(i, 2).Value = 0 Then Rows(i & ":" & i + 1).Delete

Next

    Sheets("REQUETE").Select
    ActiveWindow.SelectedSheets.Delete
   
    Sheets("PdeG").Select
    Range("A1").Select
      
    Windows("Devis.xlsm").Activate
   
    Sheets("REQUETE").Select
    Rows("4:399995").ClearContents
   
    Calculate
    ActiveWorkbook.Close SaveChanges:=True
   
End Sub

Merci d'avance.

Matthieu

 

[Lone-wolf]

Bonjour Mattieu

Il faut nettoyer le code en enlevant tous les Select(pas bon du tout) et Calculate qui est inutile lors d'un copier-coller + les variables à déclarer après Sub xxx (). Tu initialise aussi les feuilles en les déclarant par exemple : Dim WsReq As Worksheet, WsP as Worksheet, WsO As Worksheet

Ensuite, Il faut écrire comme ceci

'Après les déclarations des variables

Application.ScreenUpdating = False

Set WsReq = Sheets("REQUETE"): Set WsP = Sheets("PdeG"):  Set WsO = Sheets("OFFRE")

With WsReq
    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("A9:K" & lastrow).Sort key1:=.Range("E9"), order1:=xlAscending, Header:=xlNo
End With

WsP.Cells.Copy
WsO.Range("a1").PasteSpecial Paste:=xlPasteValues

With WsReq
'Range("F7").Select , mais à quelle feuille elle appartient??

  .Range("F7").FormulaR1C1 = "=+RC[-1]*RC[-2]"
  . Range("F7").AutoFill  .Range("F7:F96")

'Pour n'avoir que les Valeurs.
With .Range("F7:F96")
.Value = .Value
End With
End With

Il y a aussi ceci qui n'est pas normal
Sheets("PdeG").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Tu copie et colle dans la même feuille??


Et pour teminer: Activeworkbook.Close True

 

[chacal33]

Bonjour Lone Wolf et merci pour ton retour.

Effectivement, je n'ai jamais pris le temps de supprimer les Select... La méthode d'enregistrement de macro est parfois tellement pratique!

Effectivement, je copie colle dans la même feuille pour supprimer des formules que je ne souhaite pas garder.

Je vais essayer d'appliquer ce que tu proposes et je reviens vers toi!

 

[Lone-wolf]

Re chacal

Pas besoin d'un copier-coller pour ça, tu applique ceci

.Range("F7").FormulaR1C1 = "=+RC[-1]*RC[-2]"
Pour n'avoir que les valeurs
With .Range("F7:F96")
.Value = .Value
End With