XL 2013 VBA parcourir un dossier windows

[sharkantipav]

Bonjour,

J'essaye d'ecrire la macro suivante:
j'ai un fichier Hebdo qui contient 7 colonne A:G ds la Sheet SSR
Ds un dossier windows, j'ai plusieur fichier contenant le meme colonnes
Je souhaiterai que ma macro les ouvre un par un, et copie les un a la suite ds la Sheet SSR
Optionel: (marque le nom du fichier en colonne H)

voici mon code, si qqun peut le corriger. Merci bcp

Sub CheckSSR()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim endA As String
Dim endU As String

ActiveWorkbook.Worksheets("SSR").Visible = True

'Clear previous
Sheets("SSR").Select
If Range("A2") = "" Then
Range("A2").Select
Else
endA = Range("A2").End(xlDown).Row
Range("A2:G" & endA).Select
Selection.ClearContents
Range("A2").Select
End If

Dim MyFolder1 As String, MyFolder2 As String, MyFile1 As String, MyFile2 As String

MyFolder1 = "F:\xxxxxxxxxxxxx"
MyFolder2 = "F:\yyyyyyyyyyyyy"
Dim x As Workbook
Dim y As Workbook
Set y = ThisWorkbook

MyFile1 = Dir(MyFolder1 & "\", vbReadOnly)

Do While MyFile1 <> ""
    DoEvents
    On Error GoTo fin
    Set x = Workbooks.Open(Filename:=MyFolder1 & "\" & MyFile1, UpdateLinks:=False)
 
    Dim endC As String
    endC = x.ActiveSheet.Range("A2").End(xlDown).Row
    x.ActiveSheet.Range("A2:G" & endC).Copy
   
    y.Activate
   
    If y.ActiveSheet.Range("A2") = "" Then
    endD = 2
    Else
    endD = y.ActiveSheet.Range("A2").End(xlDown).Row + 1
    End If
    y.Sheets("SSR").Range("A" & endD).PasteSpecial
    x.Close
       
fin:
y.Sheets("SSR").Range("A2").Select

Loop



Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

 

[Robert]

Bonjour Sharkantipav, bonjour le forum,

Évite autant que tu le peux les Select et autre Activate inutiles. C'est la règle d'or de VBA. Il manquait juste la ligne qui permet de passer au fichier suivant... Ton code modifié :

Sub CheckSSR()
Dim CD As Workbook
Dim OD As Worksheet
Dim CA As String
Dim F As String
Dim CS As Workbook
Dim OS As Worksheet
Dim endA As Integer
Dim endC As Integer
Dim DEST As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set CD = ThisWorkbook
Set OD = CD.Worksheets("SSR")
OD.Visible = True
endA = OD.Cells(Application.Rows.Count, "A").End(wlup).Row
If endA < 2 Then endA = 2
OD.Range("A2:G" & endA).ClearContents
CA = "F:\xxxxxxxxxxxxx"
F = Dir(CA & "\", vbReadOnly)
Do While F <> ""
  On Error Resume Next
  Set CS = Workbooks.Open(CA & "\" & F, UpdateLinks:=False)
  If Err <> 0 Then
  Err.Clear
  GoTo fin
  End If
  On Error GoTo 0
  Set OS = CS.ActiveSheet
  endC = OS.Range("A2").End(xlDown).Row
  Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)
  OS.Range("A2:G" & endC).Copy DEST
  OD.DEST.Offset(0, 7).Value = F
  CS.Close False
fin:
  F = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

 

[sharkantipav]

Merci bcp
C'est parfait!!