A voir également:
- Erreur dans une macro que je n'identifie pas
- Erreur 0x80070643 - Guide
- Macro word - Guide
- Macro logiciel - Télécharger - Organisation
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Macro recorder - Télécharger - Confidentialité
3 réponses
bonjour, je viens de changer des choses dans mon code et je n'ai toujours pas le résultat escompté. je dois faire une erreur bête mais je n'arrive pas à l'identifier même avec le pas à pas
Sub synthèseClasseurs()
'
'determination des variables
Dim ClassImp As String
Dim wImp As Workbook, wRecap As Workbook
Dim fImp As Worksheet
Dim derlignRec As Long, derlignImp As Long
Dim Repertoire As String
Dim dImp As Object
Dim tRec(), tImp()
Dim i As Variant, j As Variant
Dim N As Name
'--- Limitation des applications.
Application.ScreenUpdating = False
'Set maitre = ActiveWorkbook
Set wRecap = ThisWorkbook
Repertoire = ThisWorkbook.Path
derlignRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
ClassImp = Dir(Repertoire & "\*.xls*") ' premier fichier
tRec = fRec.Range("D1:S1")
'--- On boucle les fichiers.
Set dImp = CreateObject("Scripting.Dictionary")
Do While ClassImp <> "" ' Pour chaque fichier
If ClassImp <> ThisWorkbook.Name Then
'- On ouvre le fichier.
Set wImp = Workbooks.Open(Filename:=Repertoire & "\" & ClassImp, UpdateLinks:=2)
derlignImp = 0
Set wImp = ActiveWorkbook: Set fImp = ActiveSheet
For Each N In ActiveWorkbook.Names: N.Delete: Next
With fImp
'- On véfie la ligne 1
tImp = .Range("A1:P1")
For i = LBound(tRec) To UBound(tRec)
If tRec(i, 1) <> tImp(i, 1) Then dImp(wImp.Name) = "": GoTo Suite
Next i
' on enregistre la dernière ligne
derlignImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
'on copie les lignes
.Range(Cells(2, 1), Cells(derlignImp)).Copy fRec.Cells(derlignRec, 4)
End With
Suite:
wImp.Close False
End If
ClassImp = Dir ' fichier suivant
'on recalcule la dernière ligne importé
derlignRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
Loop
'--- Limitation des applications.
Application.ScreenUpdating = True
'--- On affiche la liste des fichiers non importés dans la feuille "Fichiers en erreur"
Sheets("Fichiers en erreur").Select
Range("A1").Select
ActiveCell.Value = "Nom du fichier en erreur"
For Each j In dImp.Keys
' Mess = Mess & j & Chr(13)
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
ActiveCell.Value = j
Next j
'Call calculs
End Sub
quelqu'un voit ce qui cloche ?
merci par avance
Sub synthèseClasseurs()
'
'determination des variables
Dim ClassImp As String
Dim wImp As Workbook, wRecap As Workbook
Dim fImp As Worksheet
Dim derlignRec As Long, derlignImp As Long
Dim Repertoire As String
Dim dImp As Object
Dim tRec(), tImp()
Dim i As Variant, j As Variant
Dim N As Name
'--- Limitation des applications.
Application.ScreenUpdating = False
'Set maitre = ActiveWorkbook
Set wRecap = ThisWorkbook
Repertoire = ThisWorkbook.Path
derlignRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
ClassImp = Dir(Repertoire & "\*.xls*") ' premier fichier
tRec = fRec.Range("D1:S1")
'--- On boucle les fichiers.
Set dImp = CreateObject("Scripting.Dictionary")
Do While ClassImp <> "" ' Pour chaque fichier
If ClassImp <> ThisWorkbook.Name Then
'- On ouvre le fichier.
Set wImp = Workbooks.Open(Filename:=Repertoire & "\" & ClassImp, UpdateLinks:=2)
derlignImp = 0
Set wImp = ActiveWorkbook: Set fImp = ActiveSheet
For Each N In ActiveWorkbook.Names: N.Delete: Next
With fImp
'- On véfie la ligne 1
tImp = .Range("A1:P1")
For i = LBound(tRec) To UBound(tRec)
If tRec(i, 1) <> tImp(i, 1) Then dImp(wImp.Name) = "": GoTo Suite
Next i
' on enregistre la dernière ligne
derlignImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
'on copie les lignes
.Range(Cells(2, 1), Cells(derlignImp)).Copy fRec.Cells(derlignRec, 4)
End With
Suite:
wImp.Close False
End If
ClassImp = Dir ' fichier suivant
'on recalcule la dernière ligne importé
derlignRec = fRec.Cells.Find("*", , , , xlByRows, xlPrevious).Row
Loop
'--- Limitation des applications.
Application.ScreenUpdating = True
'--- On affiche la liste des fichiers non importés dans la feuille "Fichiers en erreur"
Sheets("Fichiers en erreur").Select
Range("A1").Select
ActiveCell.Value = "Nom du fichier en erreur"
For Each j In dImp.Keys
' Mess = Mess & j & Chr(13)
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
ActiveCell.Value = j
Next j
'Call calculs
End Sub
quelqu'un voit ce qui cloche ?
merci par avance
thev
Messages postés
1853
Date d'inscription
lundi 7 avril 2008
Statut
Membre
Dernière intervention
27 avril 2024
681
1 juin 2016 à 20:03
1 juin 2016 à 20:03
Bonjour,
j'effectuerai cette modification
j'effectuerai cette modification
' on enregistre la dernière ligne
derlignImp = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
dercolnImp = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
'on copie les lignes
.Range(Cells(2, 1), Cells(derlignImp, dercolnImp)).Copy fRec.Cells(derlignRec, 4)
thev
Messages postés
1853
Date d'inscription
lundi 7 avril 2008
Statut
Membre
Dernière intervention
27 avril 2024
681
>
cooljuly
2 juin 2016 à 11:26
2 juin 2016 à 11:26
Je regarde ce soir.
thev
Messages postés
1853
Date d'inscription
lundi 7 avril 2008
Statut
Membre
Dernière intervention
27 avril 2024
681
2 juin 2016 à 22:18
2 juin 2016 à 22:18
modification à effectuer
amélioration proposée
'- On véfie la ligne 1
tImp = .Range("A1:P1")
For i = LBound(tRec, 2) To UBound(tRec, 2)
If tRec(1, i) <> tImp(1, i) Then dImp(wImp.Name) = "": GoTo Suite
amélioration proposée
'--- On affiche la liste des fichiers non importés dans la feuille "Fichiers en erreur"
Sheets("Fichiers en erreur").Select
Range("A1").Value = "Nom du fichier en erreur"
Range("A1").Offset(1).Resize(dImp.Count).Value = Application.Transpose(dImp.Keys)