Signaler

Export feuille ado [Résolu]

Posez votre question julia Namor 341Messages postés jeudi 27 mars 2014Date d'inscription 5 septembre 2017 Dernière intervention - Dernière réponse le 18 avril 2017 à 19:15 par julia Namor
Bonjour,

Je voudrais " convertir" cette procédure d'export de feuille en méthode ADO
Une bonne volonté pour se pencher dessus ?
le fichier
http://www.cjoint.com/c/GDrqjuVZuEA
Les codes

Function RépertoireExiste(Chemin As String) As Boolean
Application.ScreenUpdating = False
On Error Resume Next
RépertoireExiste = GetAttr(Chemin) And vbDirectory
If RépertoireExiste = True Then
Exit Function
Else
MkDir (Chemin)
End If

End Function

Function FeuilleExiste2( _
wbk As Excel.Workbook, _
ByVal strFeuille As String) As Boolean
Dim strNom As String

On Error Resume Next
strNom = wbk.Sheets(strFeuille).Name
FeuilleExiste2 = (Err.Number = 0)
End Function
Function FeuilleExiste( _
wbk As Excel.Workbook, _
ByVal strFeuille As String) As Boolean
Dim Sht As Excel.Worksheet

For Each Sht In wbk.Sheets
If Sht.Name = strFeuille Then
FeuilleExiste = True
Exit Function
End If
Next

FeuilleExiste = False
End Function
Public Function FichierExiste(MonFichier As String)
'par Excel-Malin.com ( http://excel-malin.com )

If Len(Dir(MonFichier)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
End Function

Sub Bouton36_Cliquer()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim InputFile As Workbook
Dim OutputFile As Workbook
Dim fissa As String
Dim Wb As Workbook
Dim ws As Worksheet
Dim yit As String
Set InputFile = ThisWorkbook
''''///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Call RépertoireExiste(ThisWorkbook.Path & "\BACKUP" & "\Planning\")

fissa = ThisWorkbook.Path & "\BACKUP" & "\Planning\" & Sheets("Plan").Range("E13").Value & ".xlsx"

If FichierExiste(fissa) = True Then
'MsgBox "Le fichier FISSA existe..."
Else
'MsgBox "Le fichier FISSA n'existe pas..."
Workbooks.Add.SaveAs Filename:=ThisWorkbook.Path & "\BACKUP" & "\Planning\" & Sheets("Plan").Range("E13").Value & ".xlsx"
End If
Set OutputFile = Workbooks.Open(fissa)
InputFile.Activate
yit = Sheets("Plan").Range("E13").Value
'MsgBox yit
If FeuilleExiste(OutputFile, yit) Then
'MsgBox "La feuille" & yit & "existe.", vbInformation
OutputFile.Sheets(yit).Delete
Set ws = OutputFile.Sheets.Add
ws.Name = yit
Else
'MsgBox "Feuille A introuvable !", vbExclamation
Set ws = OutputFile.Sheets.Add
ws.Name = yit
End If
OutputFile.Activate
ActiveWindow.DisplayGridlines = False
'Now, copy what you want from InputFile:
InputFile.Sheets("Plan").Activate

InputFile.Sheets("Plan").Range("$E$11:$AL$34").SpecialCells(xlCellTypeVisible).Copy
OutputFile.Sheets(yit).Range("E11").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
OutputFile.Sheets(yit).Range("E11").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
InputFile.Sheets("Plan").Shapes.Range(Array("Group 1")).Select
Selection.Copy
OutputFile.Sheets(yit).Paste Destination:=OutputFile.Sheets(yit).Range("A1")


Application.CutCopyMode = False
OutputFile.Activate
OutputFile.Sheets(yit).Range("a1").Select

OutputFile.Sheets(yit).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
OutputFile.Sheets(yit).EnableSelection = xlNoSelection

OutputFile.Close SaveChanges:=1
Application.ScreenUpdating = True
MsgBox " Exporté"
End Sub


merci beaucoup



Utile
+0
plus moins
merci
Donnez votre avis

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !