Vba excel
cs_safisa
Messages postés
20
Date d'inscription
mardi 14 mars 2006
Statut
Membre
Dernière intervention
13 juillet 2008
-
18 avril 2006 à 01:52
Polack77 Messages postés 1098 Date d'inscription mercredi 22 mars 2006 Statut Membre Dernière intervention 22 octobre 2019 - 19 avril 2006 à 09:24
Polack77 Messages postés 1098 Date d'inscription mercredi 22 mars 2006 Statut Membre Dernière intervention 22 octobre 2019 - 19 avril 2006 à 09:24
A voir également:
- Vba excel
- Excel vba doevents - Conseils pratiques -Visual Basic / VB.NET
- Tous les codes vba excel - Conseils pratiques -Visual Basic / VB.NET
- Byval vba - Conseils pratiques -Visual Basic / VB.NET
- Code vba excel formulaire pdf ✓ - Forum Visual Basic 6
- Excel vba dernière ligne ✓ - Forum Visual Basic 6
6 réponses
mortalino
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
18 avril 2006 à 06:38
18 avril 2006 à 06:38
Salut Safisa,
Je pense que le mieux pour toi serait de t'enregistrer en train de copier les données de chaque page, dans la page finale. Tu auras le code de ce que tu as fait et tu pourras le modifier suivant tes besoins.
Pour des traitements simple comme ceux-là, l'enregistreur de macro s'avère etre un outil qui facilite la saisie et fait gagné du temps, restera plus qu'à supprimer les quelques propriétés inutiles !
Si tu veux le code exact, donne nous des précisions sur le nombre d'onglet et les plages de données à copier (A1:??).
@ ++
Mortalino
Je pense que le mieux pour toi serait de t'enregistrer en train de copier les données de chaque page, dans la page finale. Tu auras le code de ce que tu as fait et tu pourras le modifier suivant tes besoins.
Pour des traitements simple comme ceux-là, l'enregistreur de macro s'avère etre un outil qui facilite la saisie et fait gagné du temps, restera plus qu'à supprimer les quelques propriétés inutiles !
Si tu veux le code exact, donne nous des précisions sur le nombre d'onglet et les plages de données à copier (A1:??).
@ ++
Mortalino
Polack77
Messages postés
1098
Date d'inscription
mercredi 22 mars 2006
Statut
Membre
Dernière intervention
22 octobre 2019
1
18 avril 2006 à 13:44
18 avril 2006 à 13:44
Voila un code qui copie toute les données d'un fichier (touts les feuille) à toi de l'adapter.
Désol pour les fautes d'orthographe
'Fait par Waurzyczka Vincent
Sub Import()
Dim Tempon As Integer
Dim CptLigne As Long
Dim CptColone As Long
Dim CptFeuil As Integer: CptFeuil = 1
Dim PremLigne As Long
Dim PremColone As Long
Dim DerLigne As Long
Dim DerColone As Long
Dim CptLigneInsert As Long: CptLigneInsert = 1
'Ne fait rien si l'utilisateur répond "Non"
If MsgBox("Le programme vas vous proposer d'ouvrir un fichier." & Chr(10) & Chr(13) & "Merci de sélectionner le fichier d'où extraire les donnée." & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Attention il faut que seul le fichier contenant le programme soit ouvert." & Chr(10) & Chr(13) & "Voulez vous continuer?", vbYesNo, "Attention") = vbYes Then
Application.Dialogs(xlDialogOpen).Show 'Ouvre la fenaitre d'ouverture de fichier
'-------------------------
'Gestion d'erreur : trop de fichier ouvert
If Application.Workbooks.Count <> 2 Then
Tempon = MsgBox("Erreur trop de fichier sont ouvert merci de fermer tout fichier Excel sauf celui contenant le programme.", vbOKOnly, "Erreur")
Exit Sub
End If
'--------------------------
Application.Workbooks(1).Activate 'Active le fichier programme
Worksheets.Add 'Ajoute un onglet où mettre les donnée en tempon
Worksheets(1).Select 'Selection le nouvelle onglet
Application.Workbooks(2).Activate 'Selection du fichier d'où on prend les donnée (nomé "EXTRACT" a partir de maintenant)
Worksheets(1).Select 'Selection du 1ér onglet de "EXTRACT"
Do While CptFeuil <= Worksheets.Count 'Faire temps que tout les onglet n'on pas été verif
PremLigne = 0 '\
PremColone = 0 ' |
DerLigne = 0 ' >Initialisation des marque
DerColone = 0 ' |
CptColone = 1 '/
Worksheets(CptFeuil).Select 'Selction de la feuille suivante
Do While CptColone < 257 'Pour les 256 colone (compteur STRICTEMENT inférieur à)
CptLigne = 1 'Initialisation du compteur ligne
Do While CptLigne < 65536 'Pour toute les ligne
Cells(CptLigne, CptColone).Select 'Selectione la cellule en cours
If ActiveCell = "" Then 'Si la cellule est vide
Selection.End(xlDown).Select 'Passe directement à la valeur suivante (equivalent à la comande "Ctrl" + Fléche directionelle )
'Le compteur ligne est egale au num ligne de la cellule celectionnée
CptLigne = Val(Split(Selection.Address(True, True, xlR1C1), "R")(1))
End If
If ActiveCell <> "" Then 'Si la cellule est non vide
If PremLigne = 0 Or PremLigne > CptLigne Then 'Si la 1ér ligne non détect ou supérieur à ligne en cours
PremLigne = CptLigne 'Sauv du num ligne
End If
If DerLigne < CptLigne Then 'Si num derligne est inférieur a la ligne en cours
DerLigne = CptLigne 'Sauv du num ligne
End If
If PremColone = 0 Then 'Si 1ér colone non détect
PremColone = CptColone 'Sauv du num colone
End If
If DerColone < CptColone Then 'Si num dérinere colone inférieur à la colone en cours
DerColone = CptColone 'Sauv du num colone
End If
CptLigne = CptLigne + 1 'Passe à la ligne suivante
End If
Loop
CptColone = CptColone + 1 'Passe à la colone suivante
Loop
If PremLigne <> 0 Then 'Si des donnée on été détect (soit les marqueur défini)
Range(Cells(PremLigne, PremColone), Cells(DerLigne, DerColone)).Select 'Selectione tout ce qui est dans les marqueurs
Else
Range(Cells(1, 1), Cells(1, 1)).Select 'Selectione la 1ér cellule
End If
'-----------
'Défusione les cellule de la selection
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
'-------------
Selection.Copy 'Met dans le presse papier la selection
Application.Workbooks(1).Activate 'Retourne dans le fichier programme
Cells(CptLigneInsert, 1).Select 'Vas à la ligne compteur d'insersion
'Colle le format des donnée en presse papier (gras, couleur de cellule, ..., pas les bodure)
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Colle les donnée
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'----------------------
'Cadre autous donnée
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'----------------------
'Avance le compteur d'insersion du nombre de ligne insérer + 1 (ligne suivante de l'insertion)+ 4 ligne vide
CptLigneInsert = CptLigneInsert + DerLigne - PremLigne + 5
'Passe le marqueur d'onglet au suivant (marqueur de "EXTRACT")
CptFeuil = CptFeuil + 1
'Retourne dans le fichier "EXTRACT"
Application.Workbooks(2).Activate
Loop
End If
'Toute les donnée on été ramener dans l'onglet tempon de Programme
'Ferme le fichier "EXTRACT" sans sauvgarder le modification
Application.Workbooks(2).Close (False)
Workbooks.Add 'Crée un nouveau fichier
Application.Workbooks(2).Activate 'Active le nouveau fichier
Cells(1, 1).Select 'Selectione la 1ér cellule (haut gauche)
ActiveSheet.Paste 'Colle le contenu du presse papier
Cells(1, 1).Select 'Selectione la 1ér cellule (haut gauche)
Application.Workbooks(1).Activate 'Retourne sur le fichier programme
Application.DisplayAlerts = False 'Désactive les alerte excel (si non demande confirmation pour suprimer le tempon)
Worksheets(1).Delete 'Suprime l'onglet tempon
Application.DisplayAlerts = True 'Réactive les alerte excel
End Sub
En résumer ce code improte toute les données d'un fichier dans un nouvel onglet du fichier dans le quel se trouve le code puis crée un nouveau fichier où coller les données. Tu dois pouvoir l'adapter facilement (plien de commentaire partout)
Voila
Faut pas s'enerver
Désol pour les fautes d'orthographe
'Fait par Waurzyczka Vincent
Sub Import()
Dim Tempon As Integer
Dim CptLigne As Long
Dim CptColone As Long
Dim CptFeuil As Integer: CptFeuil = 1
Dim PremLigne As Long
Dim PremColone As Long
Dim DerLigne As Long
Dim DerColone As Long
Dim CptLigneInsert As Long: CptLigneInsert = 1
'Ne fait rien si l'utilisateur répond "Non"
If MsgBox("Le programme vas vous proposer d'ouvrir un fichier." & Chr(10) & Chr(13) & "Merci de sélectionner le fichier d'où extraire les donnée." & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Attention il faut que seul le fichier contenant le programme soit ouvert." & Chr(10) & Chr(13) & "Voulez vous continuer?", vbYesNo, "Attention") = vbYes Then
Application.Dialogs(xlDialogOpen).Show 'Ouvre la fenaitre d'ouverture de fichier
'-------------------------
'Gestion d'erreur : trop de fichier ouvert
If Application.Workbooks.Count <> 2 Then
Tempon = MsgBox("Erreur trop de fichier sont ouvert merci de fermer tout fichier Excel sauf celui contenant le programme.", vbOKOnly, "Erreur")
Exit Sub
End If
'--------------------------
Application.Workbooks(1).Activate 'Active le fichier programme
Worksheets.Add 'Ajoute un onglet où mettre les donnée en tempon
Worksheets(1).Select 'Selection le nouvelle onglet
Application.Workbooks(2).Activate 'Selection du fichier d'où on prend les donnée (nomé "EXTRACT" a partir de maintenant)
Worksheets(1).Select 'Selection du 1ér onglet de "EXTRACT"
Do While CptFeuil <= Worksheets.Count 'Faire temps que tout les onglet n'on pas été verif
PremLigne = 0 '\
PremColone = 0 ' |
DerLigne = 0 ' >Initialisation des marque
DerColone = 0 ' |
CptColone = 1 '/
Worksheets(CptFeuil).Select 'Selction de la feuille suivante
Do While CptColone < 257 'Pour les 256 colone (compteur STRICTEMENT inférieur à)
CptLigne = 1 'Initialisation du compteur ligne
Do While CptLigne < 65536 'Pour toute les ligne
Cells(CptLigne, CptColone).Select 'Selectione la cellule en cours
If ActiveCell = "" Then 'Si la cellule est vide
Selection.End(xlDown).Select 'Passe directement à la valeur suivante (equivalent à la comande "Ctrl" + Fléche directionelle )
'Le compteur ligne est egale au num ligne de la cellule celectionnée
CptLigne = Val(Split(Selection.Address(True, True, xlR1C1), "R")(1))
End If
If ActiveCell <> "" Then 'Si la cellule est non vide
If PremLigne = 0 Or PremLigne > CptLigne Then 'Si la 1ér ligne non détect ou supérieur à ligne en cours
PremLigne = CptLigne 'Sauv du num ligne
End If
If DerLigne < CptLigne Then 'Si num derligne est inférieur a la ligne en cours
DerLigne = CptLigne 'Sauv du num ligne
End If
If PremColone = 0 Then 'Si 1ér colone non détect
PremColone = CptColone 'Sauv du num colone
End If
If DerColone < CptColone Then 'Si num dérinere colone inférieur à la colone en cours
DerColone = CptColone 'Sauv du num colone
End If
CptLigne = CptLigne + 1 'Passe à la ligne suivante
End If
Loop
CptColone = CptColone + 1 'Passe à la colone suivante
Loop
If PremLigne <> 0 Then 'Si des donnée on été détect (soit les marqueur défini)
Range(Cells(PremLigne, PremColone), Cells(DerLigne, DerColone)).Select 'Selectione tout ce qui est dans les marqueurs
Else
Range(Cells(1, 1), Cells(1, 1)).Select 'Selectione la 1ér cellule
End If
'-----------
'Défusione les cellule de la selection
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
'-------------
Selection.Copy 'Met dans le presse papier la selection
Application.Workbooks(1).Activate 'Retourne dans le fichier programme
Cells(CptLigneInsert, 1).Select 'Vas à la ligne compteur d'insersion
'Colle le format des donnée en presse papier (gras, couleur de cellule, ..., pas les bodure)
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Colle les donnée
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'----------------------
'Cadre autous donnée
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'----------------------
'Avance le compteur d'insersion du nombre de ligne insérer + 1 (ligne suivante de l'insertion)+ 4 ligne vide
CptLigneInsert = CptLigneInsert + DerLigne - PremLigne + 5
'Passe le marqueur d'onglet au suivant (marqueur de "EXTRACT")
CptFeuil = CptFeuil + 1
'Retourne dans le fichier "EXTRACT"
Application.Workbooks(2).Activate
Loop
End If
'Toute les donnée on été ramener dans l'onglet tempon de Programme
'Ferme le fichier "EXTRACT" sans sauvgarder le modification
Application.Workbooks(2).Close (False)
Workbooks.Add 'Crée un nouveau fichier
Application.Workbooks(2).Activate 'Active le nouveau fichier
Cells(1, 1).Select 'Selectione la 1ér cellule (haut gauche)
ActiveSheet.Paste 'Colle le contenu du presse papier
Cells(1, 1).Select 'Selectione la 1ér cellule (haut gauche)
Application.Workbooks(1).Activate 'Retourne sur le fichier programme
Application.DisplayAlerts = False 'Désactive les alerte excel (si non demande confirmation pour suprimer le tempon)
Worksheets(1).Delete 'Suprime l'onglet tempon
Application.DisplayAlerts = True 'Réactive les alerte excel
End Sub
En résumer ce code improte toute les données d'un fichier dans un nouvel onglet du fichier dans le quel se trouve le code puis crée un nouveau fichier où coller les données. Tu dois pouvoir l'adapter facilement (plien de commentaire partout)
Voila
Faut pas s'enerver
cs_safisa
Messages postés
20
Date d'inscription
mardi 14 mars 2006
Statut
Membre
Dernière intervention
13 juillet 2008
19 avril 2006 à 00:48
19 avril 2006 à 00:48
salut;
merci bien ca a marché , mais le probleme que j'ai c'est que les données que je vais copier vont respecter l'ordre dans chaque feuille => c-à-d dans chaque feuille de rubrique j'ai parexemple coderubrique aussi intitulé et la daterubrique alor dans une seul feuille je dois copier tous les rubriques qui se trouve dans chaque feuille et les mettre dans une feuille registre mais dans cette feuille les donées qui seront copier devrons etre trier par date (je veut faire le tri dans mon macro)
Et svp aidez moi;
Et de toute façon merci ;
merci bien ca a marché , mais le probleme que j'ai c'est que les données que je vais copier vont respecter l'ordre dans chaque feuille => c-à-d dans chaque feuille de rubrique j'ai parexemple coderubrique aussi intitulé et la daterubrique alor dans une seul feuille je dois copier tous les rubriques qui se trouve dans chaque feuille et les mettre dans une feuille registre mais dans cette feuille les donées qui seront copier devrons etre trier par date (je veut faire le tri dans mon macro)
Et svp aidez moi;
Et de toute façon merci ;
Polack77
Messages postés
1098
Date d'inscription
mercredi 22 mars 2006
Statut
Membre
Dernière intervention
22 octobre 2019
1
19 avril 2006 à 08:59
19 avril 2006 à 08:59
????????????????????????????????????????????????????????????????????
Je n'ai rien compris à ce que tu veux faire.
Si tu veut le nom de ta feuille le code est
"workbooks(NumDoc).Worksheets(NumFeuille).name"
remarque : Tu peut mettre un string (qui contient le Nom du doc ou de la
feuille plutôt que leur numéro)
Et temps que au trie je n’y ai rien compris???????????
P.S. : Pense à accepter les réponses.
D'oh! Nuts!
Mmmmm...
DONUTS!!!
Je n'ai rien compris à ce que tu veux faire.
Si tu veut le nom de ta feuille le code est
"workbooks(NumDoc).Worksheets(NumFeuille).name"
remarque : Tu peut mettre un string (qui contient le Nom du doc ou de la
feuille plutôt que leur numéro)
Et temps que au trie je n’y ai rien compris???????????
P.S. : Pense à accepter les réponses.
D'oh! Nuts!
Mmmmm...
DONUTS!!!
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
mortalino
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
19 avril 2006 à 09:18
19 avril 2006 à 09:18
EEEEEh Polack, j'aime les Donuts !!
C'est clair, j'ai rien compris non plus (vu ma photo ...), mais avec le code et les commentaires que tu lui as donné, s'il ne s'en sort pas...
@ + Bonne journée !
Mortalino
C'est clair, j'ai rien compris non plus (vu ma photo ...), mais avec le code et les commentaires que tu lui as donné, s'il ne s'en sort pas...
@ + Bonne journée !
Mortalino
Polack77
Messages postés
1098
Date d'inscription
mercredi 22 mars 2006
Statut
Membre
Dernière intervention
22 octobre 2019
1
19 avril 2006 à 09:24
19 avril 2006 à 09:24
Heeeeeeee rien à voir, Mortalino si tu ti connais en bouton sur Word g un probléme et je ne m'en sort pas.
ça c'est l'adrs de ma question sur ce forum. Merci d'avence
http://www.vbfrance.com/infomsg/BOUTON-SUR-BARRE-OUTILS-WORD-2003-0_717841.aspx
D'oh! Nuts!
Mmmmm...
DONUTS!!!
ça c'est l'adrs de ma question sur ce forum. Merci d'avence
http://www.vbfrance.com/infomsg/BOUTON-SUR-BARRE-OUTILS-WORD-2003-0_717841.aspx
D'oh! Nuts!
Mmmmm...
DONUTS!!!