Amélioration de macro
Résolu
cooljuly
Messages postés
40
Date d'inscription
Statut
Membre
Dernière intervention
-
cooljuly -
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
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:
- Amélioration de macro
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Jitbit macro recorder - Télécharger - Confidentialité
- Télécharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Macro maker - Télécharger - Divers Utilitaires
- Macro word - Guide
1 réponse
Bonjour,
'1/
'xls et xlsx, mais xlsm et xlsb aussi
'2/ un exemple:
'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
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
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
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
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 Submerci.
j'avais en fait un soucis d'espace après agence.
très bonne soirée