probleme programmation

[VELO]

bonjour le forum,
j'ai besoin d'aide sur cette programmation qui reste bloquée sur la ligne rouge
en faite cette programmation:
-ouvre tous les fichiers XLS (un a un) se trouvant dans un dossier (TEST)
-copie une partie de cellule des fichiers XLS
-les colle dans mon fichier TONY feuille TARIFAIRE (si j'ai 10 fichiers XLS dans mon dossier elle me copie 10 colonnes de données dans ma feuille TARIFAIRE)
PS: je lui donne l'emplacement du dossier (C:\Documents and Settings\FRNTO2M\Bureau\TEST\) a partir de la cellule A1 de la feuille TARIFAIRE
code

Sub IMPORT()


Application.ScreenUpdating = False

R = MsgBox("Vous voulez importer les Relevés de Prix ? ", vbYesNo + vbQuestion, "EXTRACTION DES RELEVES")
If R = vbYes Then

With ActiveWorkbook
.Sheets("TARIFAIRE").Unprotect
End With

Dim W As String
 i = 9
 W = Sheets("TARIFAIRE").Range("A1") & ".xls"

   Do Until W = ""
   i = i + 1
  [COLOR="Red"]Workbooks.Open Filename:=Sheets("TARIFAIRE").Range("A1").Value & W[/COLOR]
  
  If i = 110 Or i = 112 Then i = i + 2
Worksheets(1).Unprotect ("AZERTY")
'or boeuf
ActiveWorkbook.Sheets(1).Range("c3:c5").Select
Selection.Copy
Application.Windows("TONY.xls").Activate
Cells(5, i).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Cells(5, i).Validation.Delete
Cells(6, i).Validation.Delete
Cells(7, i).Validation.Delete
Windows(2).Activate
Application.CutCopyMode = False

'le magasin
Range("d5:d6").Select
Selection.Copy
Application.Windows("TONY.xls").Activate
Cells(9, i).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Cells(9, i).Validation.Delete
Cells(10, i).Validation.Delete
Windows(2).Activate
Application.CutCopyMode = False

Worksheets(1).Protect ("AZERTY")

Application.Windows(1).Activate
 ActiveWorkbook.Close savechanges:=False
  W = Dir
  Loop


End If


 Sheets("TARIFAIRE").Select

Application.ScreenUpdating = True
    
    
End Sub

merci d'avance de votre aide
cdt
VELO

 

[James007]

Re : probleme programmation

Bonjour,

Je ne comprends pas ton code ...
Tu as déjà défini W comme le string à ouvrir ... non ?

Workbooks.Open Filename:=W

A +

 

[VELO]

Re : probleme programmation

Bonjour James,
ma programmation fonctionnée correctement (voir ci joint) mais depuis j'ai souhaité mettre l'emplacement du dossier dans une cellule beug! et c'est la raison pour laquelle je vous solucite

code:

Sub IMPORT()


Application.ScreenUpdating = False

R = MsgBox("Vous voulez importer les Relevés de Prix ? ", vbYesNo + vbQuestion, "EXTRACTION DES RELEVES")
If R = vbYes Then

With ActiveWorkbook
.Sheets("TARIFAIRE").Unprotect
End With

Dim W As String
i = 9
W = Dir("C:\Documents and Settings\FRNTO2M\Bureau\TEST\*.xls")
Do Until W = ""
i = i + 1
Workbooks.Open Filename:="C:\Documents and Settings\FRNTO2M\Bureau\TEST\" & W
If i = 110 Or i = 112 Then i = i + 2
Worksheets(1).Unprotect ("AZERTY")
'or boeuf
ActiveWorkbook.Sheets(1).Range("c3:c5").Select
Selection.Copy
Application.Windows("TONY.xls").Activate
Cells(5, i).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(5, i).Validation.Delete
Cells(6, i).Validation.Delete
Cells(7, i).Validation.Delete
Windows(2).Activate
Application.CutCopyMode = False

'le magasin
Range("d5:d6").Select
Selection.Copy
Application.Windows("TONY.xls").Activate
Cells(9, i).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(9, i).Validation.Delete
Cells(10, i).Validation.Delete
Windows(2).Activate
Application.CutCopyMode = False

Worksheets(1).Protect ("AZERTY")

Application.Windows(1).Activate
ActiveWorkbook.Close savechanges:=False
W = Dir
Loop


End If


Sheets("TARIFAIRE").Select

Application.ScreenUpdating = True


End Sub

 

[JNP]

Re : probleme programmation

Bonjour le fil 🙂,
Tu n'as pas l'impression d'avoir perdu le Dir au passage par hasard 😛 ?

W = [COLOR=red][B]Dir[/B][/COLOR]("C:\Documents and Settings\FRNTO2M\Bureau\TEST\*.xls")

Donc pour inclure le chemin avec la valeur de la cellule

W = Dir(Sheets("TARIFAIRE").Range("A1") & "*.xls")

Bonne journée 😎

 

[VELO]

Re : probleme programmation

bonjour JNP,
ta reponse fonctionne
grand merci
tres bonne journee
cdt
VELO