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.
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.