Menu

Export feuille ado [Résolu/Fermé]

julia Namor 413 Messages postés jeudi 27 mars 2014Date d'inscription 15 juin 2018 Dernière intervention - 17 avril 2017 à 18:19 - Dernière réponse : julia Namor 413 Messages postés jeudi 27 mars 2014Date d'inscription 15 juin 2018 Dernière intervention
- 18 avril 2017 à 19:15
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



Afficher la suite 

1 réponse

julia Namor 413 Messages postés jeudi 27 mars 2014Date d'inscription 15 juin 2018 Dernière intervention - 18 avril 2017 à 19:15
0
Merci
merci