Amélioration de macro

Résolu
cooljuly Messages postés 40 Date d'inscription   Statut Membre Dernière intervention   -  
 cooljuly -
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
A voir également:

1 réponse

Réponse 1 / 1
f894009 Messages postés 17272 Date d'inscription   Statut Membre Dernière intervention   1 713
 
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
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
f894009 Messages postés 17272 Date d'inscription   Statut Membre Dernière intervention   1 713 > 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
cooljuly > f894009 Messages postés 17272 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
f894009 Messages postés 17272 Date d'inscription   Statut Membre Dernière intervention   1 713 > 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
cooljuly
 
oui c'est parfait.
merci.

j'avais en fait un soucis d'espace après agence.

très bonne soirée
0

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses
recup couleur de cellule sans macro
magouero -
JvDo -

7 réponses
EXCEL transformer chiffres en lettre -facture
roland -
JBB -

26 réponses