Amélioration de macro

Résolu

cooljuly Messages postés 40 Statut Membre -
cooljuly - 11 avr. 2016 à 17:38

Bonjour,

je cherche à améliorer ma macro. il me manque 2 "petites choses" que je n'arrive pas à faire :
1/ faire en sorte que la macro puisse copier toutes les versions d'Excel et non pas que les fichiers xls mais également xlsx

Sub Synthèse()
'--- Déclaration des variables.
Dim wRec As Workbook, fRec As Worksheet, fTab As Worksheet, wImp As Workbook, fImp As Worksheet
Dim dlRec As Long, dlImp As Long, dcRec As Long, dcImp As Long, lPays As Long, lCont As Long
Dim nPoste As String, nComm As String, nRep As String, nImp As String, nPays As String, Mess As String, nCont As String
Dim tRec(), tImp()
Dim dImp As Object
Dim i As Variant, j As Variant

'--- Limitation des applications.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'--- Détermination des variables.
Set wRec = ThisWorkbook: Set fRec = Feuil1: Set fTab = Feuil4
dlRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
nRep = ThisWorkbook.Path: nImp = Dir(nRep & "\*.xls")
tRec = fRec.Range("a6:a73")

'--- On met à zéro le fichier source.
If dcRec > 1 Then With fRec: .Range(.Cells(1, 2), .Cells(1, dcRec)).EntireColumn.Delete: dcRec = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column: End With

'--- On boucle les fichiers.
Set dImp = CreateObject("Scripting.Dictionary")
Do While nImp <> ""
If nImp <> wRec.Name Then
'- On ouvre le fichier.
Workbooks.Open Filename:=nRep & "\" & nImp
dcImp = 0
Set wImp = ActiveWorkbook: Set fImp = ActiveSheet
With fImp

et en 2/ que la recherche de "nom de l'agence" ne se limite qu'à la ligne 2 et non pas à tout le fichier

dcImp = Cells.Find(What:="nom de l'agence ", After:=ActiveCell, LookIn:=xlValues _
, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 1
If dcImp = 0 Then ' Si on n'a pas de colonne avec "nom de l'agence"
dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column

un grand merci à qui pourra m'aider

Afficher la suite

1 réponse

Réponse 1 / 1
f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention 1 717
Bonjour,

'1/
'xls et xlsx, mais xlsm et xlsb aussi
```
nImp = Dir(nRep & "\*.xls*")
```
'2/ un exemple:
```
Dim dcIm As Object
Dim dcImp As Long
Set dcIm = Range("2:2").Find("nom de l'agence", lookat:=xlWhole)
If dcIm Is Nothing Then
    dcImp = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Else
    dcImp = dcIm.Column
End If
```
0
1. cooljuly
  
  bonjour,
  merci beaucoup pour ton aide.
  alors pour le 1 ça fonctionne nickel,
  par contre pour le 2, cela me génère des erreurs car la suite du code ne fonctionne pas.
  
  en fait la macro doit se stopper quand elle trouve nom de l'agence dans une colonne et passer au fichier suivant.
  
  là elle ne prends plus en compte le stop
  
  0
  1. f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention 1 717 > cooljuly
    
    Re,
    
    là elle ne prends plus en compte le stop
    Ben oui, mais n'aillant pas le code qui suivait, c'est a vous d'adapter ou montrez la suite
    
    0
  2. cooljuly > f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention
    
    ah oui pardon... j'ai pas fait attention :
    
    Sub Synthèse()
    '--- Déclaration des variables.
    Dim wRec As Workbook, fRec As Worksheet, fTab As Worksheet, wImp As Workbook, fImp As Worksheet
    Dim dlRec As Long, dlImp As Long, dcRec As Long, dcImp As Long, lPays As Long, lCont As Long
    Dim nPoste As String, nComm As String, nRep As String, nImp As String, nPays As String, Mess As String, nCont As String
    Dim tRec(), tImp()
    Dim dImp As Object
    Dim i As Variant, j As Variant
    
    '--- Limitation des applications.
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    '--- Détermination des variables.
    Set wRec = ThisWorkbook: Set fRec = Feuil1: Set fTab = Feuil4
    dlRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    nRep = ThisWorkbook.Path: nImp = Dir(nRep & "\*.xls*")
    tRec = fRec.Range("a6:a73")
    
    '--- On met à zéro le fichier source.
    If dcRec > 1 Then With fRec: .Range(.Cells(1, 2), .Cells(1, dcRec)).EntireColumn.Delete: dcRec = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column: End With
    
    '--- On boucle les fichiers.
    Set dImp = CreateObject("Scripting.Dictionary")
    Do While nImp <> ""
    If nImp <> wRec.Name Then
    '- On ouvre le fichier.
    Workbooks.Open Filename:=nRep & "\" & nImp
    dcImp = 0
    Set wImp = ActiveWorkbook: Set fImp = ActiveSheet
    With fImp
    '- On véfie la colonne A
    tImp = .Range("a3:a70")
    For i = LBound(tRec) To UBound(tRec)
    If tRec(i, 1) <> tImp(i, 1) Then dImp(wImp.Name & " Ligne " & i + 2) = "": GoTo Suite
    Next i
    '- On enregistre le nom du poste, le commentaire, dernière ligne et dernière colonne
    nComm = .Range("A71")
    nPoste = .Range("A2")
    dlImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    ' dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    ' dcImp = .Cells.Find("agence", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    dcImp = Cells.Find(What:="nom de l'agence ", After:=ActiveCell, LookIn:=xlValues _
    , LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Column - 1
    If dcImp = 0 Then ' Si on n'a pas de colonne avec "nom de l'agence"
    dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    End If
    
    '- On copie les colonnes nécessaires
    .Range(Cells(1, 2), Cells(dlImp, dcImp)).Copy fRec.Cells(4, dcRec + 1)
    End With
    
    '- On note le nom du poste
    With fRec
    .Range(.Cells(3, dcRec + 1), .Cells(3, dcRec + dcImp - 1)).Value = nPoste
    .Range(.Cells(73, dcRec + 1), .Cells(73, dcRec + dcImp - 1)).Value = nComm
    '- On ajoute la recherche
    On Error Resume Next
    lPays = WorksheetFunction.Match(nPoste, fTab.Range("a:a"), 0)
    nPays = fTab.Cells(lPays, 2).Value
    .Range(.Cells(2, dcRec + 1), .Cells(2, dcRec + dcImp - 1)).Value = nPays
    lCont = WorksheetFunction.Match(nPays, fTab.Range("b:b"), 0)
    nCont = fTab.Cells(lCont, 3).Value
    .Range(.Cells(1, dcRec + 1), .Cells(1, dcRec + dcImp - 1)).Value = nCont
    End With
    Suite:
    '- On ferme le classeur
    wImp.Close False
    End If
    '--- On cherche le fichier suivant
    nImp = Dir
    '--- On recalcule la dernière colonne
    dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    '--- On continue la boucle
    Loop
    
    '--- Limitation des applications.
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    '--- On affiche la liste des fichiers non importés dans la feuille "Compte-rendu"
    Sheets("Compte-rendu").Select
    Range("A1").Select
    ActiveCell.Value = "Messages"
    
    For Each j In dImp.Keys
    ' Mess = Mess & j & Chr(13)
    ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
    ActiveCell.Value = j
    
    Next j
    ' MsgBox Mess
    ' ActiveCell.FormulaR1C1 = "CR"
    End Sub
    
    0
  3. f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention 1 717 > cooljuly
    
    Re,
    
    A priori ca doit marcher !!
    
    Sub Synthèse() '--- Déclaration des variables. Dim wRec As Workbook, fRec As Worksheet, fTab As Worksheet, wImp As Workbook, fImp As Worksheet Dim dlRec As Long, dlImp As Long, dcRec As Long, dcImp As Long, lPays As Long, lCont As Long Dim nPoste As String, nComm As String, nRep As String, nImp As String, nPays As String, Mess As String, nCont As String Dim tRec(), tImp() Dim dImp As Object Dim i As Variant, j As Variant Dim dcIm As Object Dim dcImp As Long '--- Limitation des applications. Application.ScreenUpdating = False Application.DisplayAlerts = False '--- Détermination des variables. Set wRec = ThisWorkbook: Set fRec = Feuil1: Set fTab = Feuil4 dlRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column nRep = ThisWorkbook.Path: nImp = Dir(nRep & "\*.xls*") tRec = fRec.Range("a6:a73") '--- On met à zéro le fichier source. If dcRec > 1 Then With fRec: .Range(.Cells(1, 2), .Cells(1, dcRec)).EntireColumn.Delete: dcRec = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column: End With '--- On boucle les fichiers. Set dImp = CreateObject("Scripting.Dictionary") Do While nImp <> "" If nImp <> wRec.Name Then '- On ouvre le fichier. Workbooks.Open Filename:=nRep & "\" & nImp dcImp = 0 Set wImp = ActiveWorkbook: Set fImp = ActiveSheet With fImp '- On véfie la colonne A tImp = .Range("a3:a70") For i = LBound(tRec) To UBound(tRec) If tRec(i, 1) <> tImp(i, 1) Then dImp(wImp.Name & " Ligne " & i + 2) = "": GoTo Suite Next i '- On enregistre le nom du poste, le commentaire, dernière ligne et dernière colonne nComm = .Range("A71") nPoste = .Range("A2") dlImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row '--------------------------------------------------- 'dcImp = Cells.Find(What:="nom de l'agence ", After:=ActiveCell, LookIn:=xlValues _ , LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Column - 1 Set dcIm = .Range("2:2").Find("nom de l'agence", LookAt:=xlWhole) If dcIm Is Nothing Then dcImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column Else dcImp = dcIm.Column - 1 'pourquoi -1 ????? End If '--------------------------------------------------- '- On copie les colonnes nécessaires .Range(Cells(1, 2), Cells(dlImp, dcImp)).Copy fRec.Cells(4, dcRec + 1) End With '- On note le nom du poste With fRec .Range(.Cells(3, dcRec + 1), .Cells(3, dcRec + dcImp - 1)).Value = nPoste .Range(.Cells(73, dcRec + 1), .Cells(73, dcRec + dcImp - 1)).Value = nComm '- On ajoute la recherche On Error Resume Next lPays = WorksheetFunction.Match(nPoste, fTab.Range("a:a"), 0) nPays = fTab.Cells(lPays, 2).Value .Range(.Cells(2, dcRec + 1), .Cells(2, dcRec + dcImp - 1)).Value = nPays lCont = WorksheetFunction.Match(nPays, fTab.Range("b:b"), 0) nCont = fTab.Cells(lCont, 3).Value .Range(.Cells(1, dcRec + 1), .Cells(1, dcRec + dcImp - 1)).Value = nCont End With Suite: '- On ferme le classeur wImp.Close False End If '--- On cherche le fichier suivant nImp = Dir '--- On recalcule la dernière colonne dcRec = fRec.Cells.Find("*", , , , xlByColumns, xlPrevious).Column '--- On continue la boucle Loop '--- Limitation des applications. Application.ScreenUpdating = True Application.DisplayAlerts = True '--- On affiche la liste des fichiers non importés dans la feuille "Compte-rendu" Sheets("Compte-rendu").Select Range("A1").Select ActiveCell.Value = "Messages" For Each j In dImp.Keys ' Mess = Mess & j & Chr(13) ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate ActiveCell.Value = j Next j ' MsgBox Mess ' ActiveCell.FormulaR1C1 = "CR" End Sub
    
    0
2. cooljuly
  
  oui c'est parfait.
  merci.
  
  j'avais en fait un soucis d'espace après agence.
  
  très bonne soirée
  
  0

Amélioration de macro

1 réponse

Discussions similaires

Newsletters