Modification de macroS pour quelles puisses se "combiner"
B
Bonjour à vous le forum.
J'ai trouver cette macro sur le net qui permet d’effectuer en boucle une macro de tout le fichier d'un dossier cible choisi. Je voudrais remplacer les changement dans le classeur effectuer par ma macro. Ne sachant pas écrire en VBA il s'agit d'une macro immensément longue, qui à était pour la plus part enregistré.
Voici la macro permettant le traitement en boucle, il me semble qu'a partir de (Private Sub Test(), il s'agit de la macro a exécuter en boucle:
Public Chemin, Fich As String, ReponseMsgBox As Variant
' .
'routine d'appel depuis le bouton sur feuille
' .
Public Sub SelectionnerRepertoire()
Chemin = FLoadNomDuREP: Chemin = Trim(Chemin): If Chemin = "" Then Exit Sub
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
DoEvents
'demande de confirmation
M$ = "Traiter tous les Fichiers xls du répertoire suivant :" & vbLf & Chemin & vbLf & vbLf & "Veuillez confirmer ?"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNo, "Traitement des fichiers")
If ReponseMsgBox = vbYes Then
BoucleDeTraitement ' appel la routine de traitement des fichiers
MsgBox "Traitement terminé !", vbInformation
Else
MsgBox "Traitement abandonné !", vbExclamation
End If
End Sub
' , &H1&)=avec bouton "créer un nouveau dossier" ... , $H201&)=sans le bouton
'objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&, RepDefaut)
Private Function FLoadNomDuREP() As String
Dim objShell As Object, objFolder As Object, REP As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&)
If Not objFolder Is Nothing Then
REP = objFolder.Items.Item.Path
If Right(REP, 1) <> "\" Then REP = REP & "\"
End If
FLoadNomDuREP = REP
Set objShell = Nothing: Set objFolder = Nothing
End Function
' .
' .
Private Sub BoucleDeTraitement() ' la boucle de traitement des fichiers
Application.ScreenUpdating = False
ChDir Chemin
Fich = Dir(Chemin & "*.xls")
Do While Fich <> ""
Workbooks.Open Chemin & Fich
Test
ActiveWorkbook.Close True
Fich = Dir
Loop
Application.ScreenUpdating = True
End Sub
Private Sub Test()
'tous idem sur ActiveSheet.Cells
SousProgTest "Slope"
SousProgTest "Y-Intercept"
SousProgTest "R^2"
'celui-ci différent sur ActiveSheet.Range("A:A")
Dim cellRecherche As Range
Set cellRecherche = ActiveSheet.Range("A:A").Find("Well", , , xlPart)
While Not cellRecherche Is Nothing
cellRecherche.EntireRow.Delete
Set cellRecherche = ActiveSheet.Range("A:A").Find("Well", , , xlPart)
Wend
'
Application.Run "efface_ligne_vide"
End Sub
Private Sub SousProgTest(R$)
Dim cellRecherche As Range
Set cellRecherche = ActiveSheet.Cells.Find(R$, , , xlPart)
While Not cellRecherche Is Nothing
cellRecherche.EntireRow.Delete
Set cellRecherche = ActiveSheet.Cells.Find(R$, , , xlPart)
Wend
End Sub
Private Sub Efface_Ligne_Vide()
Dim l As Long
For l = Cells(65256, 1).End(xlUp).Row To 1 Step -1
If Cells(l, 1).Value = "" Then Cells(l, 1).EntireRow.Delete
Next l
Range("A9:F392").Select: Range("F392").Activate
Selection.Sort Key1:=Range("A9"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Cells.Select: Range("H36").Activate
Selection.Replace What:="Undetermined", Replacement:="40", LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Application.DisplayAlerts = False
SaveName = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:="Cla_" & SaveName, FileFormat:=xlText, CreateBackup:=False
Application.DisplayAlerts = True
End SubVoilà si quelqu'un peut m'aider à faire cela sa serais vraiment chouette, je vous remercie d'avance. Si de plus on peut m'indiquer ou coller et quoi modifier pour pouvoir inserer une toute autre macro à l'avenir se serais vraiment super.
Salut le forum
Basosa, merci d'utiliser la bouton Code pour la mise en forme de ton code VBA,
cela permet une meilleur lecture.
Exemple avec la balise
Public Sub SelectionnerRepertoire()
Chemin = FLoadNomDuREP: Chemin = Trim(Chemin): If Chemin = "" Then Exit Sub
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
DoEvents
'demande de confirmation
M$ = "Traiter tous les Fichiers xls du répertoire suivant :" & vbLf & Chemin & vbLf & vbLf & "Veuillez confirmer ?"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNo, "Traitement des fichiers")
If ReponseMsgBox = vbYes Then
BoucleDeTraitement ' appel la routine de traitement des fichiers
MsgBox "Traitement terminé !", vbInformation
Else
MsgBox "Traitement abandonné !", vbExclamation
End If
End SubExemple sans la balise
Public Sub SelectionnerRepertoire()
Chemin = FLoadNomDuREP: Chemin = Trim(Chemin): If Chemin = "" Then Exit Sub
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
DoEvents
'demande de confirmation
M$ = "Traiter tous les Fichiers xls du répertoire suivant :" & vbLf & Chemin & vbLf & vbLf & "Veuillez confirmer ?"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNo, "Traitement des fichiers")
If ReponseMsgBox = vbYes Then
BoucleDeTraitement ' appel la routine de traitement des fichiers
MsgBox "Traitement terminé !", vbInformation
Else
MsgBox "Traitement abandonné !", vbExclamation
End If
End Sub
Mytå
B
Merci Mytå, je voulais le faire au départ mais je ne savais pas comment.
B
J'ai nettoyé ma macro enregistré, au cas où sa puisse rendre le travail moins fastidieux. Voici donc ma macro qu'il vaudrais imbriquer sur la première ci-dessus:
Sub traduction_données_brutes()
' Touche de raccourci du clavier: Ctrl+q
'
'Titres des colonnes en ligne 1
Columns("F:G").ClearContents
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "DATE"
Range("B1").FormulaR1C1 = "HEUR"
Range("C1").FormulaR1C1 = "TEMPS ECOULE"
Range("D1").FormulaR1C1 = "SUBJECT"
Range("E1").FormulaR1C1 = "OBS"
Cells.Select
Range("G12").Activate
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Range("F2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F30795"), Type:=xlFillDefault
'liste des traduction des codes
Range("L2").Select
ActiveCell.FormulaR1C1 = " Subject0"
Range("M2").FormulaR1C1 = " Obs0"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L11"), Type:=xlFillDefault
Range("L2:L11").Select
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M9"), Type:=xlFillDefault
Range("M2:M9").Select
Range("M2:M9").Copy Destination:=Range("M10")
Range("M2:M9").Copy Destination:=Range("M18")
Range("M2:M9").Copy Destination:=Range("M26")
Range("M2:M9").Copy Destination:=Range("M34")
Range("M2:M9").Copy Destination:=Range("M42")
Range("M2:M9").Copy Destination:=Range("M50")
Range("M2:M9").Copy Destination:=Range("M58")
Range("M2:M9").Copy Destination:=Range("M66")
Range("M2:M9").Copy Destination:=Range("M74")
ActiveWindow.SmallScroll Down:=-80
Range("L2:L11").Select
Application.CutCopyMode = False
Range("L2:L11").Copy Destination:=Range("L11")
Range("L2:L9").FormulaR1C1 = " Subject0"
Range("L10:L17").FormulaR1C1 = " Subject1"
Range("L18:L25").FormulaR1C1 = " Subject2"
Range("L26:L33").FormulaR1C1 = " Subject3"
Range("L34:L41").FormulaR1C1 = " Subject4"
Range("L42:L49").FormulaR1C1 = " Subject5"
Range("L50:L57").FormulaR1C1 = " Subject6"
Range("L58:L65").FormulaR1C1 = " Subject7"
Range("L66:L73").FormulaR1C1 = " Subject8"
Range("L74:L81").FormulaR1C1 = " Subject9"
Range("L74:L81").Select
ActiveWindow.SmallScroll Down:=-95
Range("N2").FormulaR1C1 = "D"
Range("N3").FormulaR1C1 = "R"
Range("N4").FormulaR1C1 = "AFFI"
Range("N5").FormulaR1C1 = "CLINEX"
Range("N6").FormulaR1C1 = "MONO"
Range("N7").FormulaR1C1 = "M20"
Range("N8").FormulaR1C1 = "274"
Range("N9").FormulaR1C1 = "360"
Range("N10").FormulaR1C1 = "ET"
Range("N11").FormulaR1C1 = "MORDRE"
Range("N12").FormulaR1C1 = "SG"
Range("N13").FormulaR1C1 = "KO"
Range("N14").FormulaR1C1 = "G403"
Range("N15").FormulaR1C1 = "NEZ"
Range("N16").FormulaR1C1 = "277"
Range("N17").FormulaR1C1 = "PUNK"
Range("N18").FormulaR1C1 = "FO"
Range("N19").FormulaR1C1 = "PRESENT"
Range("N20").FormulaR1C1 = "DEF"
Range("N21").FormulaR1C1 = "ZORO"
Range("N22").FormulaR1C1 = "LIPS"
Range("N23").FormulaR1C1 = "P40"
Range("N24").FormulaR1C1 = "EPIS"
Range("N25").FormulaR1C1 = "G400"
Range("N26").FormulaR1C1 = "VOC"
Range("N27").FormulaR1C1 = "GENITAL"
Range("N28").FormulaR1C1 = "BB"
Range("N29").FormulaR1C1 = "2F"
Range("N30").FormulaR1C1 = "BOITE"
Range("N31").FormulaR1C1 = "E66"
Range("N32").FormulaR1C1 = "ZORO"
Range("N33").FormulaR1C1 = "MARILIN"
Range("N34").FormulaR1C1 = "MIMIC"
Range("N35").FormulaR1C1 = "MONTE"
Range("N36").FormulaR1C1 = "COPU"
Range("N37").FormulaR1C1 = "COJAK"
Range("N38").FormulaR1C1 = "ARTHUR"
Range("N39").FormulaR1C1 = "160"
Range("N40").FormulaR1C1 = "A330"
Range("N41").FormulaR1C1 = "K431"
Range("N42").FormulaR1C1 = "CHARGE"
Range("N43").FormulaR1C1 = "ATAQ"
Range("N44").FormulaR1C1 = "VOISIN"
Range("N45").FormulaR1C1 = "ALPHA"
Range("N46").FormulaR1C1 = "VIN"
Range("N47").FormulaR1C1 = "2L"
Range("N48").FormulaR1C1 = "NEIG"
Range("N49").FormulaR1C1 = "L11"
Range("N50").FormulaR1C1 = "SUP"
Range("N51").FormulaR1C1 = "ALOG"
Range("N52").FormulaR1C1 = "FLIP"
Range("N53").FormulaR1C1 = "MERT"
Range("N54").FormulaR1C1 = "BOITE"
Range("N55").FormulaR1C1 = "NARINE"
Range("N56").FormulaR1C1 = "MARILIN"
Range("N57").FormulaR1C1 = "M21"
Range("N58").FormulaR1C1 = "POUR"
Range("N59").FormulaR1C1 = "JOUER"
Range("N60").FormulaR1C1 = "ALDO"
Range("N61").FormulaR1C1 = "DIGIT"
Range("N62").FormulaR1C1 = "PELE"
Range("N63").FormulaR1C1 = "203"
Range("N64").FormulaR1C1 = "ALPHAF"
Range("N65").FormulaR1C1 = "O30"
Range("N66").FormulaR1C1 = "FRAPER"
Range("N67").FormulaR1C1 = "REPOC"
Range("N68").FormulaR1C1 = "FK"
Range("N69").FormulaR1C1 = "QAZI"
Range("N70").FormulaR1C1 = "L10"
Range("N71").FormulaR1C1 = "PP"
Range("N72").FormulaR1C1 = "DIANA"
Range("N73").FormulaR1C1 = "FOFOL"
Range("N74").FormulaR1C1 = "ATRAPER"
Range("N75").FormulaR1C1 = "TRYADE"
Range("N76").FormulaR1C1 = "REMS"
Range("N77").FormulaR1C1 = "FRER"
Range("N78").FormulaR1C1 = "AL"
Range("N79").FormulaR1C1 = "PIRAT"
Range("N80").FormulaR1C1 = "2T"
Range("N81").FormulaR1C1 = "STOP"
'Mise en forme dans une seconde feuille
Range("L2:M81").Select
Selection.Cut
ActiveWindow.SmallScroll Down:=-20
Range("K2").Select
ActiveSheet.Paste
Range("M2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M81"), Type:=xlFillDefault
Range("M2:M81").Select
ActiveWindow.SmallScroll Down:=-95
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-3]&RC[-2],R2C12:R81C14,2,FALSE)),"""",VLOOKUP(RC[-3]&RC[-2],R2C12:R81C14,2,FALSE))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-3]&RC[-2],R2C13:R81C14,2,FALSE)),"""",VLOOKUP(RC[-3]&RC[-2],R2C13:R81C14,2,FALSE))"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G44285"), Type:=xlFillDefault
Range("G2").Select
ActiveWindow.SmallScroll Down:=-30
ActiveWindow.ScrollRow = 1
Range("A1:G155").Select
ActiveWindow.ScrollRow = 1
Columns("A:G").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("D:F").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("H5").Select
Sheets("Feuil1").Select
Columns("A:A").Select
Selection.Copy
Sheets("Feuil2").Select
Columns("A:A").Select
ActiveSheet.Paste
Range("F8").Select
Range("E2").Select
ActiveCell.FormulaR1C1 = "=TIMEVALUE(RC[-3])-TEMPSVAL5"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=TIMEVALUE(RC[-3])-TIMEVALUE(R2C[-3])"
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E20000"), Type:=xlFillDefault
Range("E2").Select
ActiveWindow.ScrollRow = 1
Columns("E:E").Select
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Selection.Copy
Columns("F:F").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Columns("A:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
'je ne sais pas pourquoi je dois obligatoirement choisir une ligne et non juste la colonne!!
'se qui me fait ralentire concidérablement ma macro à l'exécution!
's'il est possible de modifier ça sa serais super
Dim I As Long
For I = Sheets("Feuil2").Cells(99999, 2).End(xlUp).Row To 1 Step -1
If Sheets("Feuil2").Cells(I, 2).Text = "#VALEUR!" Then Sheets("Feuil2").Cells(I, 2).ClearContents
Next I
Sheets.Add After:=Sheets(Sheets.Count)
Columns("A:B").Select
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Timed"
Range("A3").Select
ActiveCell.FormulaR1C1 = "D R "
Range("A4").Select
ActiveCell.FormulaR1C1 = _
"VOC MIMIC CHARGE SUP POUR FRAPER ATRAPER MORDRE GENITAL MONTE "
Range("A5").FormulaR1C1 = "AFFI SG "
Range("A6").FormulaR1C1 = "ATAS DEF"
Range("A7").FormulaR1C1 = "BB"
Range("A8").FormulaR1C1 = "COPU"
Range("A9").FormulaR1C1 = "VOISIN"
Range("A10").FormulaR1C1 = _
"FLIP ALDO FK REMS CLINEX KO ZORO 2F COJAK ALPHA MERT DIGIT QAZI FRER MONO G403 LIPS BOITE ARTHUR VIN BO PELE L10 AL M20 NEZ P40"
Range("A11").FormulaR1C1 = _
"E66 2L NARINE O203 PP PIRAT 274 277 EPIS Z A330 NEIG MA ALPHAF DIANA 2T 360 PUNK G400 MARILIN L11 M21 O30 FOFOL"
Range("A12").FormulaR1C1 = " "
Rows("10:10").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A14").FormulaR1C1 = "Individuos Machos ("
Range("A11").FormulaR1C1 = _
"FLIP ALDO FK REMS CLINEX KO ZORO 2F COJAK ALPHA MERT DIGIT QAZI FRER MONO G403 LIPS BOITE ARTHUR VIN BO PELE L10 AL M20 NEZ P40"
Range("A14").FormulaR1C1 = _
"Individuos Machos (FLIP ALDO FK REMS CLINEX KO ZORO 2F COJAK ALPHA MERT DIGIT QAZI FRER MONO G403 LIPS BOITE ARTHUR VIN BO PELE L10 AL M20 NEZ P40)"
Range("A15").FormulaR1C1 = "Individuos Embras ("
Range("A12").FormulaR1C1 = _
"E66 2L NARINE O203 PP PIRAT 274 277 EPIS Z A330 NEIG MA ALPHAF DIANA 2T 360 PUNK G400 MARILIN L11 M21 O30 FOFOL"
Range("A15").FormulaR1C1 = _
"Individuos Embras (E66 2L NARINE O203 PP PIRAT 274 277 EPIS Z A330 NEIG MA ALPHAF DIANA 2T 360 PUNK G400 MARILIN L11 M21 O30 FOFOL)"
Range("A16").FormulaR1C1 = "DIA"
Range("A17").FormulaR1C1 = "HORA "
Range("A18").FormulaR1C1 = "SEXO"
Sheets("Feuil2").Select
Range("A1:B20000").Select
Selection.Copy
Sheets("Feuil3").Select
Range("A23").Select
ActiveSheet.Paste
Dim Lg&, A As Long
Application.ScreenUpdating = False
Lg = Range("b" & Rows.Count).End(xlUp).Row + 1
With Sheets("Feuil3")
For A = 24 To Lg
If .Cells(A, "b") = "" And .Cells(A, "a") <> "/" Then .Cells(A, "a") = "/"
Next A
End With
Sheets("Feuil2").Select
Columns("A:A").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
End SubCordialement
B
Bon alors, j'ai réussis à "fusionner les deux macro pour réaliser en boucle le traitement. Pour cela j'ai changé là où il y avait xls par xlsx puis changé le nom de la macro à appeler par le mien. Mais le problème est que je n'obtient pas du tout le même résultat qu'avec ma macro effectué sur un seul dossier. De plus la boucle qui est sensé traité tout les fichier n'en traite que un seul.
Voici les deux macro fusionné:
Public Chemin, Fich As String, ReponseMsgBox As Variant
' .
'routine d'appel depuis le bouton sur feuille
' .
Public Sub SelectionnerRepertoire()
Chemin = FLoadNomDuREP: Chemin = Trim(Chemin): If Chemin = "" Then Exit Sub
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
DoEvents
'demande de confirmation
M$ = "Traiter tous les Fichiers xlsx du répertoire suivant :" & vbLf & Chemin & vbLf & vbLf & "Veuillez confirmer ?"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNo, "Traitement des fichiers")
If ReponseMsgBox = vbYes Then
BoucleDeTraitement ' appel la routine de traitement des fichiers
MsgBox "Traitement terminé !", vbInformation
Else
MsgBox "Traitement abandonné !", vbExclamation
End If
End Sub
' , &H1&)=avec bouton "créer un nouveau dossier" ... , $H201&)=sans le bouton
'objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&, RepDefaut)
Private Function FLoadNomDuREP() As String
Dim objShell As Object, objFolder As Object, REP As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&)
If Not objFolder Is Nothing Then
REP = objFolder.Items.Item.Path
If Right(REP, 1) <> "\" Then REP = REP & "\"
End If
FLoadNomDuREP = REP
Set objShell = Nothing: Set objFolder = Nothing
End Function
' .
' .
Private Sub BoucleDeTraitement() ' la boucle de traitement des fichiers
Application.ScreenUpdating = False
ChDir Chemin
Fich = Dir(Chemin & "*.xlsx")
Do While Fich <> ""
Workbooks.Open Chemin & Fich
traduction_données_brutes
ActiveWorkbook.Close True
Fich = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub traduction_données_brutes()
' Touche de raccourci du clavier: Ctrl+q
'
'Titres des colonnes en ligne 1
Columns("F:G").ClearContents
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "DATE"
Range("B1").FormulaR1C1 = "HEUR"
Range("C1").FormulaR1C1 = "TEMPS ECOULE"
Range("D1").FormulaR1C1 = "SUBJECT"
Range("E1").FormulaR1C1 = "OBS"
Cells.Select
Range("G12").Activate
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Range("F2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F30795"), Type:=xlFillDefault
'liste des traduction des codes
Range("L2").Select
ActiveCell.FormulaR1C1 = " Subject0"
Range("M2").FormulaR1C1 = " Obs0"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L11"), Type:=xlFillDefault
Range("L2:L11").Select
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M9"), Type:=xlFillDefault
Range("M2:M9").Select
Range("M2:M9").Copy Destination:=Range("M10")
Range("M2:M9").Copy Destination:=Range("M18")
Range("M2:M9").Copy Destination:=Range("M26")
Range("M2:M9").Copy Destination:=Range("M34")
Range("M2:M9").Copy Destination:=Range("M42")
Range("M2:M9").Copy Destination:=Range("M50")
Range("M2:M9").Copy Destination:=Range("M58")
Range("M2:M9").Copy Destination:=Range("M66")
Range("M2:M9").Copy Destination:=Range("M74")
ActiveWindow.SmallScroll Down:=-80
Range("L2:L11").Select
Application.CutCopyMode = False
Range("L2:L11").Copy Destination:=Range("L11")
Range("L2:L9").FormulaR1C1 = " Subject0"
Range("L10:L17").FormulaR1C1 = " Subject1"
Range("L18:L25").FormulaR1C1 = " Subject2"
Range("L26:L33").FormulaR1C1 = " Subject3"
Range("L34:L41").FormulaR1C1 = " Subject4"
Range("L42:L49").FormulaR1C1 = " Subject5"
Range("L50:L57").FormulaR1C1 = " Subject6"
Range("L58:L65").FormulaR1C1 = " Subject7"
Range("L66:L73").FormulaR1C1 = " Subject8"
Range("L74:L81").FormulaR1C1 = " Subject9"
Range("L74:L81").Select
ActiveWindow.SmallScroll Down:=-95
Range("N2").FormulaR1C1 = "D"
Range("N3").FormulaR1C1 = "R"
Range("N4").FormulaR1C1 = "AFFI"
Range("N5").FormulaR1C1 = "CLINEX"
Range("N6").FormulaR1C1 = "MONO"
Range("N7").FormulaR1C1 = "M20"
Range("N8").FormulaR1C1 = "274"
Range("N9").FormulaR1C1 = "360"
Range("N10").FormulaR1C1 = "ET"
Range("N11").FormulaR1C1 = "MORDRE"
Range("N12").FormulaR1C1 = "SG"
Range("N13").FormulaR1C1 = "KO"
Range("N14").FormulaR1C1 = "G403"
Range("N15").FormulaR1C1 = "NEZ"
Range("N16").FormulaR1C1 = "277"
Range("N17").FormulaR1C1 = "PUNK"
Range("N18").FormulaR1C1 = "FO"
Range("N19").FormulaR1C1 = "PRESENT"
Range("N20").FormulaR1C1 = "DEF"
Range("N21").FormulaR1C1 = "ZORO"
Range("N22").FormulaR1C1 = "LIPS"
Range("N23").FormulaR1C1 = "P40"
Range("N24").FormulaR1C1 = "EPIS"
Range("N25").FormulaR1C1 = "G400"
Range("N26").FormulaR1C1 = "VOC"
Range("N27").FormulaR1C1 = "GENITAL"
Range("N28").FormulaR1C1 = "BB"
Range("N29").FormulaR1C1 = "2F"
Range("N30").FormulaR1C1 = "BOITE"
Range("N31").FormulaR1C1 = "E66"
Range("N32").FormulaR1C1 = "ZORO"
Range("N33").FormulaR1C1 = "MARILIN"
Range("N34").FormulaR1C1 = "MIMIC"
Range("N35").FormulaR1C1 = "MONTE"
Range("N36").FormulaR1C1 = "COPU"
Range("N37").FormulaR1C1 = "COJAK"
Range("N38").FormulaR1C1 = "ARTHUR"
Range("N39").FormulaR1C1 = "160"
Range("N40").FormulaR1C1 = "A330"
Range("N41").FormulaR1C1 = "K431"
Range("N42").FormulaR1C1 = "CHARGE"
Range("N43").FormulaR1C1 = "ATAQ"
Range("N44").FormulaR1C1 = "VOISIN"
Range("N45").FormulaR1C1 = "ALPHA"
Range("N46").FormulaR1C1 = "VIN"
Range("N47").FormulaR1C1 = "2L"
Range("N48").FormulaR1C1 = "NEIG"
Range("N49").FormulaR1C1 = "L11"
Range("N50").FormulaR1C1 = "SUP"
Range("N51").FormulaR1C1 = "ALOG"
Range("N52").FormulaR1C1 = "FLIP"
Range("N53").FormulaR1C1 = "MERT"
Range("N54").FormulaR1C1 = "BOITE"
Range("N55").FormulaR1C1 = "NARINE"
Range("N56").FormulaR1C1 = "MARILIN"
Range("N57").FormulaR1C1 = "M21"
Range("N58").FormulaR1C1 = "POUR"
Range("N59").FormulaR1C1 = "JOUER"
Range("N60").FormulaR1C1 = "ALDO"
Range("N61").FormulaR1C1 = "DIGIT"
Range("N62").FormulaR1C1 = "PELE"
Range("N63").FormulaR1C1 = "203"
Range("N64").FormulaR1C1 = "ALPHAF"
Range("N65").FormulaR1C1 = "O30"
Range("N66").FormulaR1C1 = "FRAPER"
Range("N67").FormulaR1C1 = "REPOC"
Range("N68").FormulaR1C1 = "FK"
Range("N69").FormulaR1C1 = "QAZI"
Range("N70").FormulaR1C1 = "L10"
Range("N71").FormulaR1C1 = "PP"
Range("N72").FormulaR1C1 = "DIANA"
Range("N73").FormulaR1C1 = "FOFOL"
Range("N74").FormulaR1C1 = "ATRAPER"
Range("N75").FormulaR1C1 = "TRYADE"
Range("N76").FormulaR1C1 = "REMS"
Range("N77").FormulaR1C1 = "FRER"
Range("N78").FormulaR1C1 = "AL"
Range("N79").FormulaR1C1 = "PIRAT"
Range("N80").FormulaR1C1 = "2T"
Range("N81").FormulaR1C1 = "STOP"
'Mise en forme dans une seconde feuille
Range("L2:M81").Select
Selection.Cut
ActiveWindow.SmallScroll Down:=-20
Range("K2").Select
ActiveSheet.Paste
Range("M2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M81"), Type:=xlFillDefault
Range("M2:M81").Select
ActiveWindow.SmallScroll Down:=-95
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-3]&RC[-2],R2C12:R81C14,2,FALSE)),"""",VLOOKUP(RC[-3]&RC[-2],R2C12:R81C14,2,FALSE))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-3]&RC[-2],R2C13:R81C14,2,FALSE)),"""",VLOOKUP(RC[-3]&RC[-2],R2C13:R81C14,2,FALSE))"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G44285"), Type:=xlFillDefault
Range("G2").Select
ActiveWindow.SmallScroll Down:=-30
ActiveWindow.ScrollRow = 1
Range("A1:G155").Select
ActiveWindow.ScrollRow = 1
Columns("A:G").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("D:F").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("H5").Select
Sheets("Feuil1").Select
Columns("A:A").Select
Selection.Copy
Sheets("Feuil2").Select
Columns("A:A").Select
ActiveSheet.Paste
Range("F8").Select
Range("E2").Select
ActiveCell.FormulaR1C1 = "=TIMEVALUE(RC[-3])-TEMPSVAL5"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=TIMEVALUE(RC[-3])-TIMEVALUE(R2C[-3])"
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E20000"), Type:=xlFillDefault
Range("E2").Select
ActiveWindow.ScrollRow = 1
Columns("E:E").Select
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Selection.Copy
Columns("F:F").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Columns("A:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
'je ne sais pas pourquoi je dois obligatoirement choisir une ligne et non juste la colonne!!
'se qui me fait ralentire concidérablement ma macro à l'exécution!
's'il est possible de modifier ça sa serais super
Dim I As Long
For I = Sheets("Feuil2").Cells(99999, 2).End(xlUp).Row To 1 Step -1
If Sheets("Feuil2").Cells(I, 2).Text = "#VALEUR!" Then Sheets("Feuil2").Cells(I, 2).ClearContents
Next I
Sheets.Add After:=Sheets(Sheets.Count)
Columns("A:B").Select
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Timed"
Range("A3").Select
ActiveCell.FormulaR1C1 = "D R "
Range("A4").Select
ActiveCell.FormulaR1C1 = _
"VOC MIMIC CHARGE SUP POUR FRAPER ATRAPER MORDRE GENITAL MONTE "
Range("A5").FormulaR1C1 = "AFFI SG "
Range("A6").FormulaR1C1 = "ATAS DEF"
Range("A7").FormulaR1C1 = "BB"
Range("A8").FormulaR1C1 = "COPU"
Range("A9").FormulaR1C1 = "VOISIN"
Range("A10").FormulaR1C1 = _
"FLIP ALDO FK REMS CLINEX KO ZORO 2F COJAK ALPHA MERT DIGIT QAZI FRER MONO G403 LIPS BOITE ARTHUR VIN BO PELE L10 AL M20 NEZ P40"
Range("A11").FormulaR1C1 = _
"E66 2L NARINE O203 PP PIRAT 274 277 EPIS Z A330 NEIG MA ALPHAF DIANA 2T 360 PUNK G400 MARILIN L11 M21 O30 FOFOL"
Range("A12").FormulaR1C1 = " "
Rows("10:10").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A14").FormulaR1C1 = "Individuos Machos ("
Range("A11").FormulaR1C1 = _
"FLIP ALDO FK REMS CLINEX KO ZORO 2F COJAK ALPHA MERT DIGIT QAZI FRER MONO G403 LIPS BOITE ARTHUR VIN BO PELE L10 AL M20 NEZ P40"
Range("A14").FormulaR1C1 = _
"Individuos Machos (FLIP ALDO FK REMS CLINEX KO ZORO 2F COJAK ALPHA MERT DIGIT QAZI FRER MONO G403 LIPS BOITE ARTHUR VIN BO PELE L10 AL M20 NEZ P40)"
Range("A15").FormulaR1C1 = "Individuos Embras ("
Range("A12").FormulaR1C1 = _
"E66 2L NARINE O203 PP PIRAT 274 277 EPIS Z A330 NEIG MA ALPHAF DIANA 2T 360 PUNK G400 MARILIN L11 M21 O30 FOFOL"
Range("A15").FormulaR1C1 = _
"Individuos Embras (E66 2L NARINE O203 PP PIRAT 274 277 EPIS Z A330 NEIG MA ALPHAF DIANA 2T 360 PUNK G400 MARILIN L11 M21 O30 FOFOL)"
Range("A16").FormulaR1C1 = "DIA"
Range("A17").FormulaR1C1 = "HORA "
Range("A18").FormulaR1C1 = "SEXO"
Sheets("Feuil2").Select
Range("A1:B20000").Select
Selection.Copy
Sheets("Feuil3").Select
Range("A23").Select
ActiveSheet.Paste
Dim Lg&, A As Long
Application.ScreenUpdating = False
Lg = Range("b" & Rows.Count).End(xlUp).Row + 1
With Sheets("Feuil3")
For A = 24 To Lg
If .Cells(A, "b") = "" And .Cells(A, "a") <> "/" Then .Cells(A, "a") = "/"
Next A
End With
Sheets("Feuil2").Select
Columns("A:A").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
End Subsi vous comparez le résultat avec ma macro vous verrez l'énorme différence (c'est comme s'il effectué deux fois la macro en oubliant une partie).
Voilà si quelqu'un peut m'aider.
Merci
B
En enlevant la boucle de : Private Sub BoucleDeTraitement()
sa effectue ma macro correctement mais sa ne traite qu'un seul dossier
B
Bon c'est bon j'ai réussis a résoudre le problème je sais pas trop comment mais bon
En tout cas merci a vous