Macro mise en forme et ajout onglet

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion torvald
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
T

torvald

Guest
Bonjour à tous,

J'ai plusieurs Fichier SOURCE de même type et je voudrais à l'aide d'une macro obtenir le Fichier FINAL avec un onglet/Fichier source . Une âme charitable pourrait elle m'aider à résoudre mon problème. Merci.
 

Pièces jointes

Dernière modification par un modérateur:
Trier par date Trier par votes
Re : Macro mise en forme et ajout onglet

Bonjour torvald,
bienvenu pour ton 1er message.
Voici une macro qui fonctionne et qui demande de choisir le fichier à ouvrir
Je n'ai pas fait la somme en col "J" car c'est du texte.
J'ai oublié de renommer l'onglet mais c'est facile.
Tu peux mettre la macro dans un fichier vierge avec seulement la ligne d'entete
Bruno
PS ...........j'ai mis le fichier
Code: 
Sub mycopie()
Dim Wb As Workbook
 Dim Fichier As Variant
 [A2:Z1000].ClearContents
col = Array("", "B", "F", "I", "M", "P", "U", "X", "Z", "AC", "AH", "AI", "AK", "AN")
Fichier = Application.GetOpenFilename("Fichiers .XLS (*.xls),*.xls,Fichier .CSV(*.csv),*.csv")
If Fichier = False Then Exit Sub
Set Wb = GetObject(Fichier)
With Wb.Sheets(1)
lig = .[I14].End(xlDown).Row
For k = 1 To 13
Range(Cells(2, k), Cells(lig, k)).Value = _
.Range(.Cells(15, col(k)), .Cells(lig + 15, col(k))).Value
Next
lig = [C65000].End(3).Row + 3
Range("A" & lig) = "Amplitude:"
Range("B" & lig) = .[H9]
Range("A" & lig + 1) = "Horamètre:"
'Range("B" & lig + 1) = Application.Sum("J2:J1000")
Range("A" & lig + 2) = "Distance:"
Range("B" & lig + 2) = .[O11]
Range("A" & lig + 3) = "Odomètre :"
Range("B" & lig + 3) = .[H11]
Range("A" & lig + 4) = "Arrêt:"
Range("B" & lig + 4) = .[W9]
Range("A" & lig + 5) = "Contact:"
Range("B" & lig + 5) = .[O9]
Range("A" & lig + 6) = "Pause:"
Range("B" & lig + 6) = .[W11]
Range("A" & lig + 7) = "Roulage:"
Range("B" & lig + 7) = .[W10]
Range("A" & lig + 8) = "Moy:"
Range("B" & lig + 8) = .[O10]
Range("A" & lig + 9) = "Vit.Max:"
Range("B" & lig + 9) = .[H10]
Wb.Close

End With
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Salut Bruno,

Merci tu as raison ça marche nickel pour l'ajout d'onglet et le renommage je vais essayer de le faire c'est vraiment gentil de ta part encore une fois merci pour ta disponibilité !!!
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Suite,
Voici avec la somme en col J qui manquait et le nom de l'onglet
Bruno
Code: 
Sub mycopie()
Dim Wb As Workbook
 Dim Fichier As Variant
 [A2:Z1000].ClearContents
col = Array("", "B", "F", "I", "M", "P", "U", "X", "Z", "AC", "AH", "AI", "AK", "AN")
Fichier = Application.GetOpenFilename("Fichiers .XLS (*.xls),*.xls,Fichier .CSV(*.csv),*.csv")
If Fichier = False Then Exit Sub
Set Wb = GetObject(Fichier)
With Wb.Sheets(1)
lig = .[I14].End(xlDown).Row
For k = 1 To 13
Range(Cells(2, k), Cells(lig, k)).Value = _
.Range(.Cells(15, col(k)), .Cells(lig + 15, col(k))).Value
Next
lig = [C65000].End(3).Row + 3
Range("A" & lig) = "Amplitude:"
Range("B" & lig) = .[H9]
Range("A" & lig + 1) = "Horamètre:"
For k = 2 To lig - 3
tx = Replace(Range("J" & k), "h ", ":")
tx = Replace(tx, "mn ", ":")
tx = Replace(tx, "s", "")
Range("B" & lig + 1) = Range("B" & lig + 1) + TimeValue(tx)
Next
Range("A" & lig + 2) = "Distance:"
Range("B" & lig + 2) = .[O11]
Range("A" & lig + 3) = "Odomètre :"
Range("B" & lig + 3) = .[H11]
Range("A" & lig + 4) = "Arrêt:"
Range("B" & lig + 4) = .[W9]
Range("A" & lig + 5) = "Contact:"
Range("B" & lig + 5) = .[O9]
Range("A" & lig + 6) = "Pause:"
Range("B" & lig + 6) = .[W11]
Range("A" & lig + 7) = "Roulage:"
Range("B" & lig + 7) = .[W10]
Range("A" & lig + 8) = "Moy:"
Range("B" & lig + 8) = .[O10]
Range("A" & lig + 9) = "Vit.Max:"
Range("B" & lig + 9) = .[H10]
ActiveSheet.Name = .[D5]
Wb.Close
End With
End Sub
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Salut Bruno,

Comment vas-tu ? Le weekend pascal c'est bien passé ? Merci pour ta réactivité et excuse moi de te déranger à nouveau ,il y a un bug à la ligne
Range("B" & lig + 1) = Range("B" & lig + 1) + TimeValue(tx)

Une question est-il possible d'avoir tous les temps sous le format XXHXXmXXs ?

Merci.
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Voilà ce que j'ai ajouté pour pour avoir des feuilles supplémentaires et supprimer les lignes vides
HTML: 
Sub mycopie()
Dim Wb As Workbook
 Dim Fichier As Variant
 Dim n As Integer
n = 0
Debut:
 [A2:Z1000].ClearContents
col = Array("", "B", "F", "I", "M", "P", "U", "X", "Z", "AC", "AH", "AI", "AK", "AN")
Fichier = Application.GetOpenFilename("Fichiers .XLS (*.xls),*.xls,Fichier .CSV(*.csv),*.csv")
If Fichier = False Then Exit Sub
Set Wb = GetObject(Fichier)
With Wb.Sheets([B]n + 1[/B])
lig = .[I14].End(xlDown).Row
For k = 1 To 13
Range(Cells(2, k), Cells(lig, k)).Value = _
.Range(.Cells(15, col(k)), .Cells(lig + 15, col(k))).Value
Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'suppression ligne vide
lig = [C65000].End(3).Row + 3
Range("A" & lig) = "Amplitude:"
Range("B" & lig) = .[H9]
Range("A" & lig + 1) = "Horamètre:"
'Range("B" & lig + 1) = Application.Sum("J2:J1000")
Range("A" & lig + 2) = "Distance:"
Range("B" & lig + 2) = .[O11]
Range("A" & lig + 3) = "Odomètre :"
Range("B" & lig + 3) = .[H11]
Range("A" & lig + 4) = "Arrêt:"
Range("B" & lig + 4) = .[W9]
Range("A" & lig + 5) = "Contact:"
Range("B" & lig + 5) = .[O9]
Range("A" & lig + 6) = "Pause:"
Range("B" & lig + 6) = .[W11]
Range("A" & lig + 7) = "Roulage:"
Range("B" & lig + 7) = .[W10]
Range("A" & lig + 8) = "Moy:"
Range("B" & lig + 8) = .[O10]
Range("A" & lig + 9) = "Vit.Max:"
Range("B" & lig + 9) = .[H10]
ActiveSheet.Name = .[D5]
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
If MsgBox("Voulez-Vous ajouter un autre fichier", vbYesNo + vbExclamation, "Question") = vbNo Then Exit Sub
GoTo Debut
If MsgBox("Voulez-Vous ouvrir", vbYesNo + vbExclamation, "Question") = vbYes Then Exit Sub
Wb.Close

End With
End Sub
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Bonsoir,
Tu ne me dit pas si la supression des lignes vident supprime le bug en
Range("B" & lig + 1) = Range("B" & lig + 1) + TimeValue(tx)

Je pense que le bug venait de ces lignes vides sinon je ne vois rien d'autre
voici pour ta derniere question . . .
Bruno
Code: 
Range("A" & lig + 1) = "Horamètre:"
For k = 2 To lig - 3
tx = Replace(Range("J" & k), "h ", ":")
tx = Replace(tx, "mn ", ":")
tx = Replace(tx, "s", "")
Range("B" & lig + 1) = Range("B" & lig + 1) + TimeValue(tx)
Next
tx = Range("B" & lig + 1)
Range("B" & lig + 1) = Hour(tx) & "h " & Minute(tx) & "mn " & Second(tx) & "s"
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Salut ,

Oui la suppression des lignes vides supprime le bug encore merci pour tout
Code: 
Sub mycopie()
Dim Wb As Workbook
 Dim Fichier As Variant
  'Dim n As Integer
'n = 0
Debut:
 [A2:Z1000].ClearContents
col = Array("", "B", "F", "I", "M", "P", "U", "X", "Z", "AC", "AH", "AI", "AK", "AN")
Fichier = Application.GetOpenFilename("Fichiers .XLS (*.xls),*.xls,Fichier .CSV(*.csv),*.csv")
If Fichier = False Then Exit Sub
Set Wb = GetObject(Fichier)
With Wb.Sheets(1)
lig = .[I14].End(xlDown).Row
For k = 1 To 13
Range(Cells(2, k), Cells(lig, k)).Value = .Range(.Cells(15, col(k)), .Cells(lig + 15, col(k))).Value
Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'suppression ligne vide
lig = [C65000].End(3).Row + 3
Range("A" & lig) = "Amplitude:"
Range("B" & lig) = .[H9]
Range("A" & lig + 1) = "Horamètre:"
For k = 2 To lig - 3
tx = Replace(Range("J" & k), "h ", ":")
tx = Replace(tx, "mn ", ":")
tx = Replace(tx, "s", "")
Range("B" & lig + 1) = Range("B" & lig + 1) + TimeValue(tx)
Next
tx = Range("B" & lig + 1)
Range("B" & lig + 1) = Hour(tx) & "h " & Minute(tx) & "mn " & Second(tx) & "s"
'Range("A" & lig + 1) = "Horamètre:"
'Range("B" & lig + 1) = Application.Sum("J2:J1000")
Range("A" & lig + 2) = "Distance:"
Range("B" & lig + 2) = .[O11]
Range("A" & lig + 3) = "Odomètre :"
Range("B" & lig + 3) = .[H11]
Range("A" & lig + 4) = "Arrêt:"
Range("B" & lig + 4) = .[W9]
Range("A" & lig + 5) = "Contact:"
Range("B" & lig + 5) = .[O9]
Range("A" & lig + 6) = "Pause:"
Range("B" & lig + 6) = .[W11]
Range("A" & lig + 7) = "Roulage:"
Range("B" & lig + 7) = .[W10]
Range("A" & lig + 8) = "Moy:"
Range("B" & lig + 8) = .[O10]
Range("A" & lig + 9) = "Vit.Max:"
Range("B" & lig + 9) = .[H10]
ActiveSheet.Name = .[D5]
Range("A1:M1").Copy
If MsgBox("Voulez-Vous ajouter un autre fichier", vbYesNo + vbExclamation, "Question") = vbYes Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Cells(1, 1).Select
ActiveSheet.Paste
GoTo Debut
Else: Exit Sub
End If
Wb.Close

End With
End Sub
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Bonjour,
Exact, très bizzard
Voici une nouvelle méthode...
Bruno
Code: 
Sub mycopie()
Dim Wb As Workbook
 Dim Fichier As Variant
  'Dim n As Integer
'n = 0
Debut:
 [A2:Z1000].ClearContents
col = Array("", "B", "F", "I", "M", "P", "U", "X", "Z", "AC", "AH", "AI", "AK", "AN")
Fichier = Application.GetOpenFilename("Fichiers .XLS (*.xls),*.xls,Fichier .CSV(*.csv),*.csv")
If Fichier = False Then Exit Sub
Set Wb = GetObject(Fichier)
With Wb.Sheets(1)
lig = .[I14].End(xlDown).Row
For k = 1 To 13
.Range(.Cells(15, col(k)), .Cells(lig + 15, col(k))).Copy
Cells(2, k).PasteSpecial Paste:=xlPasteValues
Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'suppression ligne vide
lig = [C65000].End(3).Row + 3
Range("A" & lig) = "Amplitude:"
Range("B" & lig) = .[H9]
Range("A" & lig + 1) = "Horamètre:"
For k = 2 To lig - 3
tx = Replace(Range("J" & k), "h ", ":")
tx = Replace(tx, "mn ", ":")
tx = Replace(tx, "s", "")
Range("B" & lig + 1) = Range("B" & lig + 1) + TimeValue(tx)
Next
tx = Range("B" & lig + 1)
Range("B" & lig + 1) = Hour(tx) & "h " & Minute(tx) & "mn " & Second(tx) & "s"
Range("A" & lig + 2) = "Distance:"
Range("B" & lig + 2) = .[O11]
Range("A" & lig + 3) = "Odomètre :"
Range("B" & lig + 3) = .[H11]
Range("A" & lig + 4) = "Arrêt:"
Range("B" & lig + 4) = .[W9]
Range("A" & lig + 5) = "Contact:"
Range("B" & lig + 5) = .[O9]
Range("A" & lig + 6) = "Pause:"
Range("B" & lig + 6) = .[W11]
Range("A" & lig + 7) = "Roulage:"
Range("B" & lig + 7) = .[W10]
Range("A" & lig + 8) = "Moy:"
Range("B" & lig + 8) = .[O10]
Range("A" & lig + 9) = "Vit.Max:"
Range("B" & lig + 9) = .[H10]
ActiveSheet.Name = .[D5]
Range("A1:M1").Copy
If MsgBox("Voulez-Vous ajouter un autre fichier", vbYesNo + vbExclamation, "Question") = vbYes Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Cells(1, 1).Select
ActiveSheet.Paste
GoTo Debut
Else: Exit Sub
End If
Wb.Close
End With
End Sub
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Salut Youky,

Tu vas bien, la macro marche mais elle ne prend en compte que les 38 premières lignes et des fois j'ai des fichiers source avec plus 1000 lignes d'autres avec beaucoup moins le nombre varie
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Salut,
remplace cette ligne
lig = [C65000].End(3).Row + 3
par
lig = [I65000].End(3).Row + 3

Pour trouver la lig on part du bas de la colonne en remontant et dès changement c'est la ligne, le +3 c'est pour écrire 3 lignes plus bas
Je crois que la col C ne conviens pas car non rempli.
Jongle pour trouver la colonne qui est toujours la plus longue.
Change aussi parfois j'ai mis 1000 donc mets 5000 par précaution si tu as plus de 1000 lignes
Bruno
 
Vote positif 0 Vote négatif
Re : Macro mise en forme et ajout onglet

Bonsoir Youky,

Cela ne marche toujours pas apparemment c'est parce qu'il y a chaques 40 lignes des lignes vierges dans le fichier source donc il considère que c'est fini et c' est 40 premières lignes que la macro prend
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

L
  • Question Question
XL 2021 RechercheX et Mise en forme conditionnelle
2
Réponses
17
Affichages
413
Lucie85
L
jeff1494
  • Résolu(e)
XL 2021 Export d'un Userform au format Docx;
3 4 5
Réponses
60
Affichages
2 K
job75
job75
anthoYS
  • Question Question
XL 2019 Gestion de 4 sources de revenu (A, B, C et D). Et rajout du jour en cours et MEFC qui doit varier selon le mois en cours...
Réponses
8
Affichages
270
sylvanu
sylvanu
C
  • Question Question
XL 2016 récupérer la mise en forme d'une cellule vers une autre cellule
Réponses
1
Affichages
647
TooFatBoy
TooFatBoy
Y
  • Question Question
Power Query Besoin d'aide pour configurer un power query
Réponses
3
Affichages
280
alexga78
A
M
  • Résolu(e)
Microsoft 365 $ Macro pour copier un exemple et$.....
Réponses
9
Affichages
520
sousou
sousou
J
  • Résolu(e)
Microsoft 365 Impression groupée de plusieurs feuilles dans plusieurs onglets
2
Réponses
15
Affichages
782
Phil69970
Phil69970
Tony44
  • Question Question
XL 2016 Transformer la mise en forme d'un tableau
2
Réponses
22
Affichages
811
Cousinhub
Cousinhub
L
  • Question Question
XL 2021 [Résolu] Tri impossible dans un tableau mis en forme
Réponses
6
Affichages
481
LOLO13130
L
B
  • Question Question
XL 2019 probleme macro avec libre office
Réponses
5
Affichages
254
Bsm
B
yaka
  • Question Question
Microsoft 365 faire une copie d'un fichier stocké dans un sous sous... sous répertoire
2
Réponses
20
Affichages
1 K
TooFatBoy
TooFatBoy
C
  • Résolu(e)
XL 2016 Macro permettant d'automatiser le tri d'un tableau Excel et de différencier les lignes
Réponses
5
Affichages
250
Chris1263
C
D
  • Résolu(e)
XL 2019 Boucle sur plusieurs feuilles
Réponses
6
Affichages
627
dadaze
D
frederio
  • Question Question
XL 2019 Mise en forme conditionnelle la couleur
Réponses
1
Affichages
231
TooFatBoy
TooFatBoy
A
  • Question Question
XL 2016 Mise à jour stock pour articles avec nomenclature
Réponses
5
Affichages
368
vgendron
vgendron
E
  • Question Question
XL 2016 Mise en forme conditionnelle conservée après actualisation d'un TCD
Réponses
1
Affichages
330
chris
chris
D
  • Résolu(e)
XL 2016 Classeur en page web
2
Réponses
15
Affichages
644
TooFatBoy
TooFatBoy
D
  • Question Question
Microsoft 365 Mise à jour des références / liens depuis un sharepoint
Réponses
3
Affichages
684
Dégé59
D
S
  • Résolu(e)
Autres Problème avec sélection d'une cellule puis glisser
Réponses
2
Affichages
253
SPARKLETOF
S
A
  • Question Question
XL 2016 Mise en forme conditionnelle et valeur égale à 0...
Réponses
5
Affichages
470
sylvanu
sylvanu
Retour