Boucler sur des fichiers excels

Bonjour

J'avais cree un macro suivant pour recuperer des QAQC d,une annee precise, mais sa prend du temps.

Il faut les faires un a un.

Apres j'ai creer un autre fichier .xlsm ou j'ai tous les QAQC de l'annee 2019 dans chaque cellule.

Maintenant, il n'est pas possible de creer un boucle pour faire la meme chose que dans le premier fichier pour chaque cellule de ce fichier, sachant chaque cellule (A:) correspond au link du fichier .xlsm d'un QAQC et (B:) LA DATE.

Voici le macro

Sub Copy()

Dim Path As String

Dim QAQC As Variant

Dim wbQAQC As String

Dim wbFile As String

Dim BlastDate As Date

Dim Pit As String

Dim Pattern As String

Dim SurveyXY_V_Design_NC As Variant

Dim DrilledXY_V_Design_NC As Variant

Dim Design_Charge As Variant, Actual_Charge As Variant, Volume As Variant

Dim DrilledD_V_Design As Variant, ChargedD_V_Design As Variant, Stemming_NC As Variant

Dim HDesigned As Integer, HMarked As Integer, HDrilled As Integer, HCharged As Integer

Dim Underdcharged As Variant, Overcharged As Variant, CorrectlyCharged As Variant, Charged_ShortD As Variant, Charged_LongD As Variant, Charged_correctD As Variant

Application.ScreenUpdating = False

Sheets("Run").Select

Path = Range("C7").Value

wbFile = Range("C8").Value

Do

ChDir Path

QAQC = Application.GetOpenFilename _

(Title:="Please choose a QAQC file to open", _

FileFilter:="XlS *.xls* (*.xls*),")

wbQAQC = Mid(QAQC, InStrRev(QAQC, "\") + 1)

If QAQC = False Then

MsgBox "No file selected.", vbExclamation, "Sorry!"

Application.ScreenUpdating = True

Exit Do

Else

Workbooks.Open Filename:=QAQC

Windows(wbQAQC).Activate

Sheets("TYPED INPUTS").Select

BlastDate = Range("E2").Value

Pit = Range("E3").Value

Pattern = Range("C2").Value

Volume = Range("C10").Value

Design_Charge = Range("K8").Value

Actual_Charge = Range("K9").Value

HDesigned = Range("K16").Value

HMarked = Range("K17").Value

HDrilled = Range("K18").Value

HCharged = Range("K19").Value

Underdcharged = Range("K22").Value

Overcharged = Range("K23").Value

CorrectlyCharged = Range("K25").Value

Charged_ShortD = Range("K26").Value

Charged_LongD = Range("K27").Value

Charged_correctD = Range("K29").Value

Sheets("CALCULATED INPUTS").Select

SurveyXY_V_Design_NC = Range("AA6").Value

DrilledXY_V_Design_NC = Range("AG6").Value

DrilledD_V_Design_NC = Range("AM6").Value

ChargedD_V_Design_NC = Range("AY6").Value

Stemming_NC = Range("BX6").Value

Workbooks(wbQAQC).Close False

Windows(wbFile).Activate

Sheets("Data_DB_QAQC").Select

Range("A1").Select

Selection.End(xlDown).Select

ActiveCell.Offset(1, 0).Select

ActiveCell.Value = BlastDate

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Pit

ActiveCell.Offset(0, 2).Select

ActiveCell.Value = Pattern

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Volume

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HDesigned

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HMarked

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HDrilled

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HCharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Design_Charge

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Actual_Charge

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Underdcharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Overcharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = CorrectlyCharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Charged_ShortD

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Charged_LongD

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Charged_correctD

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = SurveyXY_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = DrilledXY_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = DrilledD_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = ChargedD_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Stemming_NC

ActiveCell.Offset(0, 1).Select

Loop

Application.ScreenUpdating = True

End Sub

Merci de m'aider.

Bonjour Sidate, bonjour le forum,

À quoi sert la date en colonne B si tu dis que le fichier contient tous les fichiers de 2019 ? Le boucle devrait donc s'effectuer sur toutes les cellules éditées de la colonne A. Peux-tu confirmer ?

Bonjour ThauTheme, bonjour le forum,

Oui je confirme la date en ce moment ne sert plus a rien, j'ai Tous les fichiers de 2019 en colonne A.

Mais il m'a fallut filtrer et suprimer les autres.

A l'avenir je voudrais aussi eviter se travail la aussi, Quand j'aurais d'autres annees, si possible.

Merci,

Sidate.

Re,

Pour éviter de perdre du temps, je te propose de nous faire parvenir une fichier exemple avec plusieurs années.

J'ai déja un code prêt maie je veux pouvoir le tester avant de t'envoyer...

Re,

Ok, ThauTheme voici un exemple du fichier. j'ai constater que dans la colonne date il y'a aussi des heures. J'en ai pas besoin.

Merci,

Babacar.

2qaqc-listes-2.xlsm (18.33 Ko)

Re,

la règle d'or en VBA c'est d'éviter les Select autant que possible. Ils ne font que ralentir l'exécution du code et sont source de plantage...

Essaie comme ça :

Sub Macro1()
Dim BlastDate As Date
Dim Pit As String
Dim Pattern As String
Dim SurveyXY_V_Design_NC As Variant
Dim DrilledXY_V_Design_NC As Variant
Dim Design_Charge As Variant, Actual_Charge As Variant, Volume As Variant
Dim DrilledD_V_Design As Variant, ChargedD_V_Design As Variant, Stemming_NC As Variant
Dim HDesigned As Integer, HMarked As Integer, HDrilled As Integer, HCharged As Integer
Dim Underdcharged As Variant, Overcharged As Variant, CorrectlyCharged As Variant, Charged_ShortD As Variant, Charged_LongD As Variant, Charged_correctD As Variant

Dim CD As Workbook
Dim CS As Workbook
Dim CA As String
Dim BE As Variant
Dim TV As Variant
Dim I As Integer
Dim DL As Integer

Application.ScreenUpdating = False
Set CD = ThisWorkbook
CA = CD.Worksheets("Run").Range("C7").Value & "\"
BE = Application.InputBox("Quelle année voulez-vous traiter", "ANNÉE", Type:=1)
If BE = False Then Exit Sub
With CD.Worksheets("Sheet1")
    TV = .Range("A1").CurrentRegion
    For I = 1 To UBound(TV, 1)
        If Year(TV(I, 2)) = BE Then
            Workbooks.Open CA & TV(I, 1)
            Set CS = ActiveWorkbook
            With CS.Worksheets("TYPED INPUTS")
                BlastDate = .Range("E2").Value
                Pit = .Range("E3").Value
                Pattern = .Range("C2").Value
                Volume = .Range("C10").Value
                Design_Charge = .Range("K8").Value
                Actual_Charge = .Range("K9").Value
                HDesigned = .Range("K16").Value
                HMarked = .Range("K17").Value
                HDrilled = .Range("K18").Value
                HCharged = .Range("K19").Value
                Underdcharged = .Range("K22").Value
                Overcharged = .Range("K23").Value
                CorrectlyCharged = .Range("K25").Value
                Charged_ShortD = .Range("K26").Value
                Charged_LongD = .Range("K27").Value
                Charged_correctD = .Range("K29").Value
            End With

            With CS.Sheets("CALCULATED INPUTS")
                SurveyXY_V_Design_NC = .Range("AA6").Value
                DrilledXY_V_Design_NC = .Range("AG6").Value
                DrilledD_V_Design_NC = .Range("AM6").Value
                ChargedD_V_Design_NC = .Range("AY6").Value
                Stemming_NC = .Range("BX6").Value
            End With
            CS.Close False

            CD.Activate
            With CD.Worksheets("Data_DB_QAQC")
                DL = .Cells(Application.Rows.Count, "A").End(xlUp).Row + 1
                .Cells(DL, "A").Value = BlastDate
                .Cells(DL, "B").Value = Pit
                .Cells(DL, "D").Value = Pattern
                .Cells(DL, "E").Value = Volume
                .Cells(DL, "F").Value = HDesigned
                .Cells(DL, "G").Value = HMarked
                .Cells(DL, "H").Value = HDrilled
                .Cells(DL, "I").Value = HCharged
                .Cells(DL, "J").Value = Design_Charge
                .Cells(DL, "K").Value = Actual_Charge
                .Cells(DL, "L").Value = Underdcharged
                .Cells(DL, "M").Value Overcharged
                .Cells(DL, "N").Value = CorrectlyCharged
                .Cells(DL, "O").Value = Charged_ShortD
                .Cells(DL, "P").Value = Charged_LongD
                .Cells(DL, "Q").Value = Charged_correctD
                .Cells(DL, "R").Value = SurveyXY_V_Design_NC
                .Cells(DL, "S").Value = DrilledXY_V_Design_NC
                .Cells(DL, "T").Value = DrilledD_V_Design_NC
                .Cells(DL, "U").Value = ChargedD_V_Design_NC
                .Cells(DL, "V").Value = Stemming_NC
            End With
        End If
    Next I
End With
Application.ScreenUpdating = True
MsgBox "Traitement des données terminé !"
End Sub

Re,

Oui c'est j'ai essaye le code, mais il m'affiche qu'il ne voit pas le link. Le probleme c'est au niveau de la cellule "c7".

Tu pense qu'il n'est pas plus facile de copier tous les fichiers .xlsm dans un dossier et creer un code ou il va excuter en boucle les fichiers le restant du code.

Un dossier QAQC dans le quel on a les fichiers .xlsm nommer comme dans le fichier joint.

Et la cellule "c7" sera le link du dossier.

El la feuille 2 nommer dans le fichier collecte les informations.

Sorry du retard pour repondre.

Merci,

Bonjour

J'essayes avec ce code pour boucler tous les fichiers .xlsm du dossier, mais il m'envoie un message d'erreur et souligne la ligne

Workbooks.Open strFileName := strFileList(i). J'ai enlever le str derriere le Filename mais tjr rien.

Plaese veut tu verifier s'il n'y a pas d'autres erreures.

Merci.

Sub BoucleFile()

Dim BlastDate As Date

Dim Pit As String

Dim Pattern As String

Dim SurveyXY_V_Design_NC As Variant

Dim DrilledXY_V_Design_NC As Variant

Dim Design_Charge As Variant, Actual_Charge As Variant, Volume As Variant

Dim DrilledD_V_Design As Variant, ChargedD_V_Design As Variant, Stemming_NC As Variant

Dim HDesigned As Integer, HMarked As Integer, HDrilled As Integer, HCharged As Integer

Dim Underdcharged As Variant, Overcharged As Variant, CorrectlyCharged As Variant, Charged_ShortD As Variant, Charged_LongD As Variant, Charged_correctD As Variant

Dim wbSource, wbFichierUsager As Workbook

Dim strFileName, strPath, strSpec As String

Dim strFileList() As String

Dim i, FoundFiles As Integer

Set webFichierUsager = ThisWorkbook

strPath = "C:\Users\babacar.mandiang\Desktop\QAQC-2019\GOW_2019_QAQC"

strSpec = strPath & "*.xlsm*"

strFileName = Dir(strSpec)

If strFileName <> " " Then

FoundFiles = FoundFiles + 1

ReDim Preserve strFileList(1 To FoundFiles)

strFileList(FoundFiles) = strPath & strFileName

Else

MsgBox "Aucun fichier trouve"

Exit Sub

End If

Do

strFileName = Dir(strSpec)

If strFileName <> " " Then Exit Do

FoundFiles = FoundFiles + 1

ReDim Preserve strFileList(1 To FoundFiles)

strFileList(FoundFiles) = strPath & strFileName

Loop

For i = 1 To FoundFiles

Workbooks.Open strFileName := strFileList(i)

Set wbSource = ActiveWorkbook

Sheets("TYPED INPUTS").Select

BlastDate = Range("E2").Value

Pit = Range("E3").Value

Pattern = Range("C2").Value

Volume = Range("C10").Value

Design_Charge = Range("K8").Value

Actual_Charge = Range("K9").Value

HDesigned = Range("K16").Value

HMarked = Range("K17").Value

HDrilled = Range("K18").Value

HCharged = Range("K19").Value

Underdcharged = Range("K22").Value

Overcharged = Range("K23").Value

CorrectlyCharged = Range("K25").Value

Charged_ShortD = Range("K26").Value

Charged_LongD = Range("K27").Value

Charged_correctD = Range("K29").Value

Sheets("CALCULATED INPUTS").Select

SurveyXY_V_Design_NC = Range("AA6").Value

DrilledXY_V_Design_NC = Range("AG6").Value

DrilledD_V_Design_NC = Range("AM6").Value

ChargedD_V_Design_NC = Range("AY6").Value

Stemming_NC = Range("BX6").Value

Set webFichierUsager = ThisWorkbook

Sheets("Data_DB_QAQC").Select

Range("A1").Select

Selection.End(xlDown).Select

ActiveCell.Offset(1, 0).Select

ActiveCell.Value = BlastDate

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Pit

ActiveCell.Offset(0, 2).Select

ActiveCell.Value = Pattern

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Volume

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HDesigned

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HMarked

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HDrilled

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = HCharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Design_Charge

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Actual_Charge

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Underdcharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Overcharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = CorrectlyCharged

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Charged_ShortD

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Charged_LongD

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Charged_correctD

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = SurveyXY_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = DrilledXY_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = DrilledD_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = ChargedD_V_Design_NC

ActiveCell.Offset(0, 1).Select

ActiveCell.Value = Stemming_NC

ActiveCell.Offset(0, 1).Select

wbSource.Close SaveChanges:=False

Next i

End Sub

Re,

Il me semble que je t'avait dit qu'il fallait éviter les Select !... Et je t'avais proposé même une solution, qui n'a pas convenu certes, mais qui les supprimait tous . Visiblement tu ne tiens pas compte des avis. Je passe la main...

Re,

J'essaye tjr d'utiliser ton code. J'avais pas bien compris cette ligne CA = CD.Worksheets("Run").Range("C7").Value & "\".

Merci encore pour t'on n'aide.

Rechercher des sujets similaires à "boucler fichiers excels"