Résolu Copier des données de plusieurs classeurs excel dans un autre classeur en VBA

  • Auteur de la discussion Alex90000
  • Date de début

Alex90000

Nouveau membre
Bonjour à tous,

Je suis novice sur ce forum et j'ai besoin de votre aide.
Je voudrai créer un programme qui puisse être capable d'aller chercher des infos dans plusieurs classeurs Excel (en fonction d'un n° de semaine choisit) puis, me coller ces infos dans un fichier commun ("MC_Commun").
Tous les classeurs se trouve dans le même dossier.

J'ai réussi avec un 1 fichier (MC_Shootage) mais, je ne sais pas comment gérer avec plusieurs fichiers ? Existe t'il une fonction multiFichier ou qqch comme ça?

Voici mon pgm:

Code:
Sub Dechet_Finition_Hebdo()

'Identification des chemins et des fichiers

    Dim Chemin As String, WbDestination As Workbook, WbSource As Workbook
    Dim Fichier As String
    Dim Semaine As Long, L As Long, x As Long
    Set WbDestination = ThisWorkbook
    L = WbDestination.Worksheets("Donnees").Range("A65536").End(xlUp).Row + 1
    WbDestination.Worksheets("Donnees").Range("A6:N" & L).ClearContents
  
     'Chemin = "X:\30_QUALITE\307_Gestion_de_service\AAAA-Main-Courante-Atelier\Recherches pour MC_commun\MC_commun"
    Chemin = ThisWorkbook.Path    'si les 2 fichiers dans même dossier
    
    'demande à l'utilisateur le numéro de semaine, semaine en cours par défaut
    Semaine = InputBox("N° de la semaine", "SEMAINE", DatePart("ww", Date, vbMonday) - 1)
    If Semaine = 0 Then Exit Sub
    Fichier = "MC_Shootage.xlsm"
    If FichierExiste(Chemin & "\" & Fichier) Then

    'ouverture du fichier en lecture seule
        Workbooks.Open Filename:=Chemin & "\" & Fichier, UpdateLinks:=0, ReadOnly:=True
        Set WbSource = ActiveWorkbook
        On Error Resume Next
        x = Application.WorksheetFunction.CountIf(WbSource.Worksheets("Synthese").Range("B5:B1000"), "=" & Semaine)
            If x > 0 Then
        With WbSource.Worksheets("Synthese")
                'Transfert des données
                'exemple pour ajout de ligne(s)
                For Each cel In .Range("B6:B1000")
                    If cel = Semaine Then
                        L = WbDestination.Worksheets("Donnees").Range("A65536").End(xlUp).Row + 1
                         .Range("A" & cel.Row & ":N" & cel.Row).Copy Destination:=WbDestination.Worksheets("Donnees").Range("A" & L)
                    End If
                Next cel
        End With

        WbSource.Close SaveChanges:=False
            Else
        WbSource.Close SaveChanges:=False
            End If
      End If
End Sub

Function FichierExiste(NomFichier As String) As Boolean
    FichierExiste = Dir(NomFichier) <> "" And NomFichier <> ""
End Function

Merci à tous ceux qui pourront m'aider!!
 

zeb

Modérateur
Meilleure réponse
Salut,

Pas mal ce bout de code. Des tas de choses bien écrites. Mais j'y vois aussi quelques erreurs mineures.

N'utilise pas la fonction Dir(). Elle déclenche des mécanismes archaïques et consommateur de ressources pour rien. Regarde plutôt FileExists() du FileSystemObject.

T'as vraiment mis la variable derrière le Next ! C'était très utile en 1985. Depuis, on a inventé l'indentation. Oublie ça.

Si x > 0 Alors ... WbSource.Close SaveChanges:=False Sinon WbSource.Close SaveChanges:=False.
Y'a rien qui te gène ? ;)

Tu lis des fichiers xlsm. Je suppose donc que tu es sur une version récente d'Excel. Et donc Range("A65536") n'est plus la dernière cellule de la colonne A.
La dernière cellule de la première colonne est : Columns(1).Cells(Application.Rows.Count)

InputBox peut renvoyer un peu n'importe quoi.
Je t'invite à vérifier que l'utilisateur a bien saisi un nombre entre 1 et 53 :
Code:
If Not CInt(semaine) Then Exit Sub
If Semaine < 1 or Semaine > 53 Then Exit Sub

Pourquoi ce "On Error Resume Next" ?

Eh, tu demandes à Excel de compter combien de fois "semaine" est présent. Puis tu parcours (For Each) toute la plage.
Mouhais :/ T'embêtes pas. Parcours donc directement ta zone, il n'y a que 996 lignes à vérifier.

Code:
If cel = Semaine Then
Cel est un range, Semaine est un nombre. C'est pas terrible. Précise que c'est bien la valeur qui t'intéresse.
Code:
If cel.Value = Semaine Then

M'enfin quelle idée de recalculer L à chaque fois ! L = L + 1 devrait suffire dans la boucle.

------------------------------

Bon, ça ne t'avance peut-être pas dans la résolution de ton problème.
En fait, je n'ai pas tout compris.

Qu'est-ce que ce "multiFichier" qui t'aiderait ?
En fait, voudrais-tu ouvrir, lire puis refermer tous les fichiers du répertoire ?

Si oui, alors regarde ce bout de code.
Code:
Dim FSO As Object ' New Scripting.FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")

Dim chemin As String
chemin = FSO.GetParentFolderName(ThisWorkbook.Path)

' Si le classeur n'a pas de chemin
If Not FSO.FolderExists(chemin) Then 
	Dim WSH  As Object ' New Scripting.FileSystemObject
	Set WSH = CreateObject("WScript.Shell")
	chemin = WSH.SpecialFolders("Desktop")
	Set WSH = Nothing
End If

' Mais comment est-ce possible ?
' Ben, quoi, si le classeur est un nouveau fichier, il n'a pas de chemin, ni de nom de fichier.

Dim f As Scripting.File
Dim wb As Workbook

For Each f In FSO.GetFolder(chemin).Files
    If UCase(FSO.GetExtensionName(f.Name)) Like "XLS*" Then
        Set wb = Workbooks.Open(Filename:=f.Path, UpdateLinks:=0, ReadOnly:=True)

        ' faire des trucs avec le classeur ouvert

        wb.Close SaveChanges:=False
    End If
Next
 

Lyn___

Nouveau membre
SVP je veux faire le transfert de données d'une cellule ou+ de plusieurs fichiers Excel dans un seul fichier Excel global automatiquement, svp c quoi le code VBA qui permet de faire ça ?
ça fait 10 jours que je cherche ça dans le net, mais pas de réponse qui a résolu mon blem :/ ,svp c urgent je dois remettre ça demain au prof svp :(
Cordialement,
Lynda :)
 

drul

Obscur pro du hardware
Staff
On ne traite aucun sujet urgent ici. Inutile de remonter un vieux topic en plus du tient.
Zeb est à la "retraite" depuis un moment.
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Derniers messages publiés
Statistiques globales
Discussions
730 098
Messages
6 717 065
Membres
1 586 286
Dernier membre
petitangebleu1977
Partager cette page
Haut