Excel 2007 [MACRO] ouverture de fichier .XLS dans un dossier

Le 28/11/2012 à 11:18

Bonjour à tous

Cela fait une semaine que je m'essai aux macros sous excel 2007.

Donc j'ai reussi grace a ce forum à avancer et faire que mon fichier excel soit presque automatique.

Mais vient à moi un nouveau problème. J'aimerai que quand j'ouvre mon fichier .XLSM qu'il aille ouvrir un par un des fichiers .XLS qui se trouve dans un dossier précis. et qu'il effectue les différentes taches que j'ai deja mise en place.

une macro qui remplace les X par une celulle qui est sur la meme ligne. (qui marche pour le moment avec un bouton)

Option Explicit

Sub Remplaces()
Dim Cel As Range

  With Sheets("Depot_Oracle")
    Set Cel = .Cells.Find(what:="x", LookIn:=xlValues, lookat:=xlWhole)
    If Not Cel Is Nothing Then
      Do
        Cel = Range("C" & Cel.Row)
        Set Cel = .Cells.FindNext(Cel)
      Loop While Not Cel Is Nothing
    End If
  End With

End Sub

une macro qui permet de remanier un tableau et de le disposer comme je le veux. (qui marche quand on va sur l'onglet)

Option Explicit

Private Sub Worksheet_Activate()

Dim Der_Col As Integer
Dim Der_Lig As Long

Application.ScreenUpdating = False

Der_Col = Sheets("Depot_Oracle").UsedRange.Columns.Count
Der_Lig = Range("A" & Rows.Count).End(xlUp).Row + 1

With Sheets("Depot_Oracle")
'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne der_col)
  .Range(.Cells(2, 5), .Cells(2, Der_Col)).Copy
'Vers cellule B2 en copiant juste la valeur
      Range("B" & Der_Lig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    .Range(.Cells(7, 5), .Cells(7, Der_Col)).Copy
        Range("D" & Der_Lig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    .Range(.Cells(3, 5), .Cells(3, Der_Col)).Copy
        Range("C" & Der_Lig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    .Range(.Cells(9, 5), .Cells(9, Der_Col)).Copy
        Range("E" & Der_Lig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    .Range(.Cells(6, 5), .Cells(6, Der_Col)).Copy
        Range("A" & Der_Lig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    .Range(.Cells(8, 5), .Cells(8, Der_Col)).Copy
        Range("F" & Der_Lig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With

'Application.CutCopyMode = False
Range("A8").Select
End Sub

Donc je me suis poser la question de comment ouvrir un fichier

j'ai optenu ce bout de code en enregistrant une macro:

Sub Macro1()
'
' Macro1 Macro
'

'
    ChDir _
        "C:\Database inventory Done"
    Workbooks.Open Filename:= _
        "C:\Database inventory Done\inventory.xlsx"
End Sub

Donc dans le cas ou je spécifie le chemin exacte ça va. mais quand j'essai de viser l'ensemble des fichiers. avec *.xls cela ne marche pas.

Du coup je me demandais comment on pouvait:

ouvrir le premier fichier .XLS du dossier.

récuperer la feuille qui est dedans.

l'affecter dans mon fichier dans la feuille Depot oracle.

et realiser toutes mes macros à la suite.

puis faire la meme chose avec tous les fichiers .xls qui suivent dans le dossier.

Je ne sais pas si c'est possible. si quelqu'un peut m'aider?

Je vous met en fichier joint: mon fichier avec mes macros. + le fichier à ouvrir.

43inventory-a-ouvrir.xlsx (118.48 Ko)

34inventaire-a-remplir-avec-macro.xlsm (45.07 Ko)

Je remercie par avance toutes les peronnes qui vont m'aider à me perfectionner.

Rapt

Le 29/11/2012 à 00:54

Bonjour

A quoi te sert la macro "Remplaces" car tu ne te sers pas des résultats , Le prochain fichier écrasera les données ?

Le 29/11/2012 à 01:22

Bonjour

Une version à tester

55raptorzil-regroupe-v001.xlsm (52.73 Ko)

Le 29/11/2012 à 09:13

En fait la macro remplace me sert c'est juste qu' j'ai pas encore fait une macro pour exploiter les donner apres. je le faisais a la main pour le moment ^^

Le 29/11/2012 à 09:42

En tout cas je te remercies je vais analyser ton code. moi je trouve une erreur 1004 quand j'essai d'ouvrir un de mes fichiers d'origines qui ont un nom assez long.

Le 29/11/2012 à 11:41

Bon alors tu m'as bien aider. merci Banzai.

Par contre ce que je comprends pas c'est que Dir() m'oublie des fichiers et ne passe pas au fichier suivant mais a celui d'apres

du coup il me scanne la moitié des fichiers. une idée du pourquoi?

mon code est celui-ci maintenant.

Option Explicit

Sub Recupere()
Dim DerCol As Integer
Dim Chemin As String
Dim Fichier As String
Dim WsDestin_Oracle As Worksheet
Dim WsDestin_SQL_Server As Worksheet
Dim WsDestin_Other As Worksheet
Dim DerLig As Long

  Application.ScreenUpdating = False

  Set WsDestin_Oracle = Sheets("ORACLE")
  Set WsDestin_SQL_Server = Sheets("SQL_Server")
  Set WsDestin_Other = Sheets("MySQL & Other DB")

  Chemin = ThisWorkbook.Path & "\"
  Fichier = Chemin & Dir(Chemin & "*.xlsx")

  Do While Fichier <> ""

    With Workbooks.Open(Fichier)
        'Oracle
      If .Sheets(3).Name = "Oracle" Then
        DerLig = WsDestin_Oracle.Range("A" & Rows.Count).End(xlUp).Row + 1
        With .Sheets(3)
          DerCol = .Cells(2, Columns.Count).End(xlToLeft).Column

          .Range(.Cells(2, 5), .Cells(2, DerCol)).Copy     'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne DerCol)
          WsDestin_Oracle.Range("B" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Vers cellule B2 en copiant juste la valeur

          .Range(.Cells(7, 5), .Cells(7, DerCol)).Copy
          WsDestin_Oracle.Range("D" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(3, 5), .Cells(3, DerCol)).Copy
          WsDestin_Oracle.Range("C" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(9, 5), .Cells(9, DerCol)).Copy
          WsDestin_Oracle.Range("E" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(6, 5), .Cells(6, DerCol)).Copy
          WsDestin_Oracle.Range("A" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(8, 5), .Cells(8, DerCol)).Copy
          WsDestin_Oracle.Range("F" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End With
      End If
      'SQL_Server
      If .Sheets(4).Name = "SQL Server" Then
        DerLig = WsDestin_SQL_Server.Range("A" & Rows.Count).End(xlUp).Row + 1
        With .Sheets(4)
          DerCol = .Cells(2, Columns.Count).End(xlToLeft).Column

          .Range(.Cells(2, 5), .Cells(2, DerCol)).Copy     'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne DerCol)
          WsDestin_SQL_Server.Range("B" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Vers cellule B2 en copiant juste la valeur

          .Range(.Cells(7, 5), .Cells(7, DerCol)).Copy
          WsDestin_SQL_Server.Range("D" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(3, 5), .Cells(3, DerCol)).Copy
          WsDestin_SQL_Server.Range("C" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(9, 5), .Cells(9, DerCol)).Copy
          WsDestin_SQL_Server.Range("E" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(6, 5), .Cells(6, DerCol)).Copy
          WsDestin_SQL_Server.Range("A" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(8, 5), .Cells(8, DerCol)).Copy
          WsDestin_SQL_Server.Range("F" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End With
      End If
      'Other DB
      If .Sheets(5).Name = "MySQL & Other DB" Then
        DerLig = WsDestin_Other.Range("A" & Rows.Count).End(xlUp).Row + 1   'Select
        With .Sheets(5)
          DerCol = .Cells(2, Columns.Count).End(xlToLeft).Column

          .Range(.Cells(2, 5), .Cells(2, DerCol)).Copy     'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne DerCol)
          WsDestin_Other.Range("B" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Vers cellule B2 en copiant juste la valeur

          .Range(.Cells(7, 5), .Cells(7, DerCol)).Copy
          WsDestin_Other.Range("D" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(3, 5), .Cells(3, DerCol)).Copy
          WsDestin_Other.Range("C" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(9, 5), .Cells(9, DerCol)).Copy
          WsDestin_Other.Range("E" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(6, 5), .Cells(6, DerCol)).Copy
          WsDestin_Other.Range("A" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(8, 5), .Cells(8, DerCol)).Copy
          WsDestin_Other.Range("F" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End With
      End If
      .Close 'Ferme fichier
    End With
    If Len(Dir()) <> 0 Then 'Test si Dir() different de 0
        Fichier = Chemin & Dir() 'affecte Chemin + Dir()
    Else
        Fichier = "" 'Sinon affecte ""
    End If
  Loop
  Application.Goto WsDestin_Oracle.Range("A1")
End Sub

en fait je crois savoir... Vu que je fais un test

If Len(Dir()) <> 0 Then 'Test si Dir() different de 0
        Fichier = Chemin & Dir() 'affecte Chemin + Dir()
    Else
        Fichier = "" 'Sinon affecte ""
    End If

j'appelle du coup deux fois le Dir()....

Une idée pour tester si Dir() = 0 sans l'appeler deux fois?

Le 29/11/2012 à 12:02

j'ai trouvé !

Code final :

Option Explicit

Sub Recupere()
Dim DerCol As Integer
Dim Chemin As String
Dim Fichier As String
Dim Result As String

Dim WsDestin_Oracle As Worksheet
Dim WsDestin_SQL_Server As Worksheet
Dim WsDestin_Other As Worksheet
Dim DerLig As Long

  Application.ScreenUpdating = False

  Set WsDestin_Oracle = Sheets("ORACLE")
  Set WsDestin_SQL_Server = Sheets("SQL_Server")
  Set WsDestin_Other = Sheets("MySQL & Other DB")

  Chemin = ThisWorkbook.Path & "\"
  Result = Dir(Chemin & "*.xlsx")
  Fichier = Chemin & Result

  Do While Fichier <> ""

    With Workbooks.Open(Fichier)
        'Oracle
      If .Sheets(3).Name = "Oracle" Then
        DerLig = WsDestin_Oracle.Range("A" & Rows.Count).End(xlUp).Row + 1
        With .Sheets(3)
          DerCol = .Cells(2, Columns.Count).End(xlToLeft).Column

          .Range(.Cells(2, 5), .Cells(2, DerCol)).Copy     'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne DerCol)
          WsDestin_Oracle.Range("B" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Vers cellule B2 en copiant juste la valeur

          .Range(.Cells(7, 5), .Cells(7, DerCol)).Copy
          WsDestin_Oracle.Range("D" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(3, 5), .Cells(3, DerCol)).Copy
          WsDestin_Oracle.Range("C" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(9, 5), .Cells(9, DerCol)).Copy
          WsDestin_Oracle.Range("E" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(6, 5), .Cells(6, DerCol)).Copy
          WsDestin_Oracle.Range("A" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(8, 5), .Cells(8, DerCol)).Copy
          WsDestin_Oracle.Range("F" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End With
      End If
      'SQL_Server
      If .Sheets(4).Name = "SQL Server" Then
        DerLig = WsDestin_SQL_Server.Range("A" & Rows.Count).End(xlUp).Row + 1
        With .Sheets(4)
          DerCol = .Cells(2, Columns.Count).End(xlToLeft).Column

          .Range(.Cells(2, 5), .Cells(2, DerCol)).Copy     'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne DerCol)
          WsDestin_SQL_Server.Range("B" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Vers cellule B2 en copiant juste la valeur

          .Range(.Cells(7, 5), .Cells(7, DerCol)).Copy
          WsDestin_SQL_Server.Range("D" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(3, 5), .Cells(3, DerCol)).Copy
          WsDestin_SQL_Server.Range("C" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(9, 5), .Cells(9, DerCol)).Copy
          WsDestin_SQL_Server.Range("E" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(6, 5), .Cells(6, DerCol)).Copy
          WsDestin_SQL_Server.Range("A" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(8, 5), .Cells(8, DerCol)).Copy
          WsDestin_SQL_Server.Range("F" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End With
      End If
      'Other DB
      If .Sheets(5).Name = "MySQL & Other DB" Then
        DerLig = WsDestin_Other.Range("A" & Rows.Count).End(xlUp).Row + 1   'Select
        With .Sheets(5)
          DerCol = .Cells(2, Columns.Count).End(xlToLeft).Column

          .Range(.Cells(2, 5), .Cells(2, DerCol)).Copy     'Copie cellule (Ligne 2 colonne 5) jusqu'à (Ligne DerCol)
          WsDestin_Other.Range("B" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Vers cellule B2 en copiant juste la valeur

          .Range(.Cells(7, 5), .Cells(7, DerCol)).Copy
          WsDestin_Other.Range("D" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(3, 5), .Cells(3, DerCol)).Copy
          WsDestin_Other.Range("C" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(9, 5), .Cells(9, DerCol)).Copy
          WsDestin_Other.Range("E" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(6, 5), .Cells(6, DerCol)).Copy
          WsDestin_Other.Range("A" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True

          .Range(.Cells(8, 5), .Cells(8, DerCol)).Copy
          WsDestin_Other.Range("F" & DerLig).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End With
      End If
      .Close 'Ferme fichier
    End With
    Result = Dir()
    If Len(Result) <> 0 Then 'Test si Dir different de 0
        Fichier = Chemin & Result 'affecte Chemin + Dir
    Else
        Fichier = "" 'Sinon affecte ""
    End If
  Loop
  Application.Goto WsDestin_Oracle.Range("A1")
End Sub

Rechercher des sujets similaires à "2007 macro ouverture fichier xls dossier"