Transferts de donnee en automaticque
bonjour
es ce quelqu'un peu m 'aider a créer une macro pour transfert mes données en automatique
j ai une feuille de la machine et je veut savoir toute les pièces qui seront affecte en 2017 , 2018
je désire copier toutes les lignes qui sont en jaunes dans une autre feuille "2017" a condition qui est la lettre R dans la colonne N
et copier dans la feuille 2018 toute les lignes a conditions qu'il y aun R dans la colonne O
merci de votre aide!
Bonjour,
A tester (bouton sur feuille dienst)
Sub RévisionProgramméeAnnée()
Dim Tr(), a, n%, i%, k%, j%, r%, ws As Worksheet
Do
a = InputBox("Indiquez l'année de révisin que vous souhaitez récapituler", _
"Récapitulation des révisions par années")
If a = "" Then Exit Sub
k = 14
With Worksheets("dienst")
Do
If .Cells(4, k) = CInt(a) Then Exit Do
k = k + 1
Loop Until .Cells(4, k) = ""
If .Cells(4, k) = "" Then
MsgBox "Pas de colonne correspondant à l'année demandée ! Vérifier.", _
vbCritical, "Erreur"
Exit Sub
End If
End With
On Error Resume Next
Set ws = Worksheets(CStr(a))
If Err.Number <> 0 Then
MsgBox "Pas de feuille correspondant à l'année demandée ! Vérifier.", _
vbCritical, "Erreur"
Exit Sub
End If
On Error GoTo 0
a = Array(1, 2, 3, 4, 5, 6, 7, 10, 12, 13)
With Worksheets("dienst")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 5 To n
If .Cells(i, k) = "R" Then
ReDim Preserve Tr(9, r)
For j = 0 To 9
Tr(j, r) = .Cells(i, a(j))
Next j
r = r + 1
End If
Next i
End With
With ws
.Range("A1").CurrentRegion.Offset(2).ClearContents
.Range("A3").Resize(r, 10).Value = WorksheetFunction.Transpose(Tr)
End With
If MsgBox("Souhaitez-vous récapituler une autre année ?", vbQuestion + vbYesNo, _
"Récapitulation des révisions par années") = vbNo Then Exit Do
Set ws = Nothing: a = Empty: r = 0
Loop
End SubLa procédure questionne l'utilisateur sur l'année qu'il souhaite récapituler, elle vérifie que la colonne existe, puis que l'année existe (et s'interrompt après signalisation si ce n'est pas le cas). En fin, elle redemande à l'utilisateur si autre année à récapituler, s'il répond oui, on recommence... si non on s'arrête.
En cas d'erreur, on peut reprendre la procédure, elle efface la récap antérieure sans toucher à l'en-tête de la feuille cible.
Cordialement.
un grand merci a vous cela va bien m aider
il me reste juste a transfère le resultat dans un autre fichier au lieu d'une autre feuille
encore merci
re bonjour
afin de la retranscrire sur mon vrai fichier peut tu m expliquer ton petit programme merci
cordialement
Bonsoir yeti55, MFerrand,
Une autre façon de procéder :
Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, ii As Byte, ws As Worksheet
a = Sheets("dienst").Range("a4").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For j = 14 To UBound(a, 2)
.Item(CStr(a(3, j))) = Empty
For i = 4 To UBound(a, 1)
If a(i, j) = "R" Then
If IsEmpty(.Item(CStr(a(3, j)))) Then
ReDim w(1 To 10, 1 To 1)
Else
w = .Item(CStr(a(3, j)))
ReDim Preserve w(1 To 10, 1 To UBound(w, 2) + 1)
End If
For ii = 1 To 7
w(ii, UBound(w, 2)) = a(i, ii)
Next
w(8, UBound(w, 2)) = a(i, 10)
w(9, UBound(w, 2)) = a(i, 12)
w(10, UBound(w, 2)) = a(i, 13)
.Item(CStr(a(3, j))) = w
End If
Next
Next
For Each ws In Worksheets
If .exists(ws.Name) Then
ws.Range("A1").CurrentRegion.Offset(2).ClearContents
If Not IsEmpty(.Item(ws.Name)) Then
ws.Range("A3").Resize(UBound(.Item(ws.Name), 2), UBound(.Item(ws.Name), 1)).Value = _
Application.Transpose(.Item(ws.Name))
End If
End If
Next
End With
End Subklin89
Bonjour,
il me reste juste a transfère le resultat dans un autre fichier au lieu d'une autre feuille
encore merci
afin de la retranscrire sur mon vrai fichier peut tu m expliquer ton petit programme merci
cordialement
J'avais déjà indiqué, la procédure est structurée de façon à pouvoir être adaptée de façon souple. Sa structure, 'externe' en quelque sorte, est constituée par une boucle Do... Loop qui se répètera autant de fois que tu le demandes ! A chaque fois tu traites une année, on vérifie que l'année existe dans la feuille (colonne) et dans le fichier (feuille cible), on réalise l'opération et on te demande si tu en veux une autre...
Ce dispositif occupe un peu plus de la moitié du code, pour l'adapter à une configuration qui ne serait pas strictement identique, il faut voir que cela repose sur : ta ligne d'en-tête en ligne 4 et les colonnes années à tester à partir de N.
Paramètre : k = 14 (=N) et .Cells(4, k)..., on incrémente k pour passer d'une colonne à la suivante, jusqu'à tomber sur une cellule vide...
Comme tu vois, si on changeait ces éléments : ligne 4 et colonne N, les adaptations devraient être assez faciles.
Bien évidemment la recherche des données constituant l'opération, commence ligne 5 ! Si la ligne 4 change, ce sera la ligne qui suit...
L'opération elle-même est faite dans cette partie du code :
a = Array(1, 2, 3, 4, 5, 6, 7, 10, 12, 13)
With Worksheets("dienst")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 5 To n
If .Cells(i, k) = "R" Then
ReDim Preserve Tr(9, r)
For j = 0 To 9
Tr(j, r) = .Cells(i, a(j))
Next j
r = r + 1
End If
Next i
End With
With ws
.Range("A1").CurrentRegion.Offset(2).ClearContents
.Range("A3").Resize(r, 10).Value = WorksheetFunction.Transpose(Tr)
End WithDéfinition d'un tableau a des numéros de colonnes à prélever. Si changement en la matière, il suffit donc d'ajuster ce tableau.
Boucle sur les ligne de la colonne année demandée pour trouver les "R".
Quand on en trouve un, on incrémente un tableau de recueil des données à 10 colonnes (0 à 9) au moyen d'une variable r (qui ajoute une ligne en conservant les données déjà recueillies : ReDim Preserve Tr(9, r).
On sert la ligne de ce tableau en prélevant les données des colonnes recensées au tableau a.
Et on poursuit ... A la fin, on efface le contenu antérieur de la feuille cible et on y affecte le tableau des données recueillies (tranposé car structure Tr(colonnes, lignes)).
Comme tu vois, le processus reste relativement simple et donc pouvant s'adapter à des situations très diverses.
Cordialement.
Re,
Petite question :
L'absence de "R" dans une colonne est-elle un cas à traiter, cela n'a pas été précisé
klin89
c'est parce que le fichier est trop gros !
des que j arrive a le zippe je le met en ligne car j ai aime l approche de mr ferrand
le fichier source
et le fichier révision
a+ bonne soirée
on va y arriver en tous les cas merci encore
voici le vrai fichier les "premiere feuille
voila le deuxieme fichier
quand j appuie sur le bouton " pièce révision dienst" ca me demande l annee concerne et ca le copie dans la feuille dienst les cellule qui son en jaune
et ca met en gros l annee que j ai demande
merci
Je peux concevoir que tu aies quelques difficultés d'adaptation !
Je ne suis d'ailleurs pas sûr de l'interpréter correctement : on commande à partir de boutons dont le libellé fournira le nom de la feuille d'extraction dans un autre classeur, si la méthode peut en gros rester la même, les paramètres de recherche sont quelque peu modifiés...
La structure reste à préciser ou confirmer, et autre petit problème indépendant, tu m'as l'air un peu fâché avec les caractères accentués... et comme je ne vois aucune raison d'omettre les accents lorsqu'il y en a
Cordialement.
étant novice dans le code VBA ,je me forme a travers des tutos ! je croyais que c'était facile de retranscrire une macro mais non c'est un métier
explication du problème :
je crois être clair dans mes explication
sauf que mon fichier comporte 16 feuilles et là il y a que 2 feuilles mais, c'est le même tableau dans toutes les feuilles ! es ce que je pourrai faire un copier/coller de la macro en changement le nom de la feuille
encore merci de ton aide
Bonjour,
J'essaie de voir plus tard dans la journée les modifs à apporter : ouverture classeur source, recherche feuille sur nom (au lieu de l'année), recherche de l'année... La structure répétitive ne se justifie plus (c'est l'action bouton qui commande)...
Bonne journée
re
Pour faire simple, j'ai placé des 2 classeurs dans le même dossier
Le classeur cible est fermé
Exécute la macro à partir du classeur source
Dernier point : fais attention aux noms de tes feuilles pour la recherche de correspondance
Option Explicit
Sub test()
Dim a, i As Long, ii As Byte, dLig As Long, col, w(), dico As Object, ws As Worksheet
Dim bon As Boolean, an As String
Application.ScreenUpdating = False
Do While Not bon
an = InputBox("veuillez entrer un année comprise entre 2017 et 2022")
If StrPtr(an) = 0 Then Exit Do ' -->> on a annulé
If an Like "####" And Val(an) >= 2017 And Val(an) <= 2022 Then bon = True
Loop
MsgBox IIf(bon, "vous avez saisi " & an, "vous avez annulé")
If bon = False Then Exit Sub
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
'source
For Each ws In ThisWorkbook.Worksheets
dico.Item(ws.Name) = Empty
col = Application.Match(CInt(an), ws.Rows(4), 0)
If IsNumeric(col) Then
dLig = ws.Range("a" & Rows.Count).End(xlUp).Row
a = ws.Range(ws.Cells(7, 1), ws.Cells(dLig, 36))
For i = 1 To UBound(a, 1)
If a(i, col) = "R" Then
If IsEmpty(dico.Item(ws.Name)) Then
ReDim w(1 To 9, 1 To 1)
Else
w = dico.Item(ws.Name)
ReDim Preserve w(1 To 9, 1 To UBound(w, 2) + 1)
End If
For ii = 1 To 7
w(ii, UBound(w, 2)) = a(i, ii)
Next
w(8, UBound(w, 2)) = a(i, 14)
w(9, UBound(w, 2)) = a(i, 15)
dico.Item(ws.Name) = w
End If
Next
End If
Next
'cible
With Workbooks.Open(ThisWorkbook.Path & "\cibleRevision.xls")
For Each ws In .Worksheets
If dico.exists(ws.Name) Then
ws.Range("A4").CurrentRegion.Offset(1).ClearContents
ws.Range("G2").Value = CInt(an)
If Not IsEmpty(dico.Item(ws.Name)) Then
ws.Range("A5").Resize(UBound(dico.Item(ws.Name), 2), UBound(dico.Item(ws.Name), 1)).Value = _
Application.Transpose(dico.Item(ws.Name))
End If
End If
Next
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Bonsoir,
Préparation : renommage des boutons en utilisant le nom machine dans le nom du bouton. La macro modifiée est affectée à tous les boutons, elle détectera celui qui appelle...
La macro vient naturellement dans le classeur à partir duquel l'opération est commandée (qui doit donc passer en xlsm).
J'ai considéré que le classeur pièce1 n'ayant pas de macro serait en xlsx (rectifier si ce n'est pas le cas).
J'ai considéré aussi que les deux classeurs étaient dans le même dossier (rectifier le chemin si ce n'est pas le cas).
Le classeur source peut être ouvert ou non ouvert, la macro l'ouvrira s'il ne l'est pas. Elle ne le ferme pas, puisque l'utilisateur peut réaliser plusieurs opérations à la suite...
J'ai (exceptionnellement) mis des commentaires, qui devraient te permettre de te repérer dans le code...
Il me paraîtrait aussi souhaitable que tu apportes un peu plus de soin à l'orthographe en faisant en sorte que les mêmes mots soient bien toujours écrits de la même façon, et que tu évites les espaces parasites (j'ai bien failli laisser un certain nombre d'anomalies pour te permettre d'en apprécier les conséquences !
Mais tu en auras peut-être quelques unes...
Sub RévisionProgramméeAnnée()
Dim Tr(), a, col, n%, i%, k%, j%, r%, m$, wbS As Workbook
'Identification bouton appelant (machine)
m = Replace(Application.Caller, "pr_", "")
'Effacement feuille cible (sous gestion d'erreur)
On Error GoTo NoFeuil1
ThisWorkbook.Worksheets(m).Range("A4").CurrentRegion.Offset(1).ClearContents
'Prise en charge classeur source (ouverture sous gestion d'erreur s'il y a lieu)
On Error GoTo OuvrirWbkS
Application.ScreenUpdating = False
Set wbS = Workbooks("piece 1.xlsx")
On Error GoTo 0
'Recueil de l'année de révision
a = InputBox("Indiquez l'année de révision que vous souhaitez récapituler pour " _
& "la machine " & m & ".", "Récapitulation de révisions annuelles")
If a = "" Then Exit Sub
'Prise en charge feuille source (sous gestion d'erreur)
On Error GoTo NoFeuil2
With wbS.Worksheets(m)
On Error GoTo 0
'Recherche colonne année (interruption si non trouvée)
k = 21
Do
If .Cells(4, k) = CInt(a) Then Exit Do
k = k + 3
Loop While .Cells(4, k) <> ""
If .Cells(4, k) = "" Then
MsgBox "Pas de colonne correspondant à l'année demandée dans la feuille " _
& "source ! Vérifier.", vbCritical, "Erreur"
Exit Sub
End If
'Recueil des données
col = Array(1, 2, 3, 4, 5, 6, 7, 14, 15)
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 7 To n
If .Cells(i, k) = "R" Then
ReDim Preserve Tr(8, r)
For j = 0 To 8
Tr(j, r) = .Cells(i, col(j))
Next j
r = r + 1
End If
Next i
End With
'Affectation à la feuille cible
With ThisWorkbook.Worksheets(m)
.Range("F2") = CInt(a)
.Range("A5").Resize(r, 9).Value = WorksheetFunction.Transpose(Tr)
End With
'Message de fin...
MsgBox "La récapitulation des révisions " & a & " pour la machine " & m _
& " a été réalisée.", vbInformation, "Programme de révisions"
'Retour feuille de commande (si classeur a été ouvert, elle n'est plus la feuille active)
ThisWorkbook.Worksheets("revision ").Activate
Exit Sub
OuvrirWbkS:
'Ouverture du classeur source
Set wbS = Workbooks.Open(ThisWorkbook.Path & "\piece 1.xlsx")
Resume Next
NoFeuil1:
'Feuille cible manquante
MsgBox "La feuille " & m & " n'est pas présente dans le classeur !", vbCritical, _
"Erreur Feuille"
Exit Sub
NoFeuil2:
'Feuille source manquante
MsgBox "La feuille " & m & " manque dans le classeur source !", vbCritical, _
"Erreur Feuille source"
End Subj essaie tout ca je vous tiens au courant
encore un grand merci à vous
bonne journée
bonjour a vous
super
j ai opte pour la macro de Mferrant
col = Array(1, 2, 3, 4, 5, 6, 7, 14, 15)
"la récapitulation des révisions 2017 pour la machine Schreyer a été réalise"
alors que j ai bien la bonne base qui a été enregistrer
bonne journée a vous !
Bonjour,
es ce possible si je rajoute des années par la suite ,est ca que ca fonctionne toujours
C'est toi qui indique l'année, si l'année est trouvée dans le fichier source, pas de problème !
NB- Il convient de conserver la même structure sur la feuille source (colonne révision toutes les 3 colonnes). La macro tient compte de cet espacement pour éviter tes cellules fusionnées sur la ligne 4
es ce possible que lorsqu'on choisit l 'année, de mettre l année en cours par défaut
A ajouter sur cette ligne :
a = InputBox("Indiquez l'année de révision que vous souhaitez récapituler pour " _
& "la machine " & m & ".", "Récapitulation de révisions annuelles", Year(Date))
si je raoute une colonne je modifie la ligne la de la macro en rajoutant le numéro de la colonne col = Array(1, 2, 3, 4, 5, 6, 7, 14, 15)
col est un tableau qui liste les colonnes à prélever sur la feuille source, dans l'ordre où il faudra les restituer sur la feuille cible.
Actuellement un tableau de 9 éléments, indices de 0 à 8.
Si tu en modifies le nombre, il convient simultanément d'ajuster le dimensionnement du tableau, la boucle de prélèvement et le dimensionnement de la plage cible lors de l'affectation.
On va donc procéder de la façon suivante pour ne pas avoir à modifier autre chose que les indications de colonnes du tableau :
1) Ajout d'une variable nbC : déclaration :
Dim Tr(), a, col, n%, i%, k%, j%, r%, nbC%, m$, wbS As Workbook2) Initialisation de la variable après initialisation du tableau et utilisation dans le reste du code à la place de l'indication en "dur" :
'Recueil des données
col = Array(1, 2, 3, 4, 5, 6, 7, 14, 15)
nbC = UBound(col)
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 7 To n
If .Cells(i, k) = "R" Then
ReDim Preserve Tr(nbC, r)
For j = 0 To nbC
Tr(j, r) = .Cells(i, col(j))
Next j
r = r + 1
End If
Next i
End With
'Affection à la feuille cible
With ThisWorkbook.Worksheets(m)
.Range("F2") = CInt(a)
.Range("A5").Resize(r, nbC + 1).Value = WorksheetFunction.Transpose(Tr)
End With(suite à venir...)
petite question lorsque j ai copier le bouton "paletiseur "ca marque a la fin "la récapitulation des révisions 2017 pour la machine Schreyer a été réalise"
alors que j ai bien la bonne base qui a été enregistrer
Là, je ne vois pas bien ce que tu as fait... mais ce dont je suis sûr, c'est qu'il faut éviter de procéder ainsi (sans veiller au nom des boutons) !
Comme tu peux le voir sur l'image ci-dessus, lorsque tu sélectionnes un de tes boutons (sélection par clic droit pour ne pas déclencher la macro), son nom apparaît dans la zone Nom (située à gauche de la barre de formules).
Ce nom est contitué par "pr_" suivi du nom de feuille (feuille source dans le classeur source, feuille cible dans le classeur cible).
On peut modifier ce nom dans cette zone Nom (le nouveau nom doit être validé en appuyant sur Entrée, et il convient de vérifier qu'il soit bien pris en compte).
C'est la même macro qui est affectée à tous les boutons. La macro identifie le bouton qui l'a appelée par son nom.
La ligne suivante :
m = Replace(Application.Caller, "pr_", "")extrait dans la variable m [m pour machine !] le nom machine auquel correspond le nom de feuille, du nom du bouton.
Et c'est ce nom qui est utilisé dans la suite pour identifier les feuilles concernées et intervenir sur elles :
ThisWorkbook.Worksheets(m).Range("A4").CurrentRegion.Offset(1).ClearContentsqui efface les données préexistantes de la feuille cible.
a = InputBox("Indiquez l'année de révision que vous souhaitez récapituler pour " _
& "la machine " & m & ".", "Récapitulation de révisions annuelles", Year(Date))indication du nom machine dans le message de l'InputBox (pour éviter une erreur éventuelle).
With wbS.Worksheets(m)pour intervention sur la feuille source.
With ThisWorkbook.Worksheets(m)pour affectation des données prélevées à la feuille cible.
MsgBox "La récapitulation des révisions " & a & " pour la machine " & m _
& " a été réalisée.", vbInformation, "Programme de révisions"rappel du nom machine traitée dans le message de confirmation de la réalisation de l'opération.
Ainsi, si tu ne veilles pas à la stricte correspondance du nom du bouton avec un nom de machine, lui-même correspondant aux noms de feuilles source et cible, tu risques une erreur d'exécution ou (si l'action peut se dérouler sans erreur) que la réalisation soit différente de ce que tu as cru commander...
Alors, attention aux copier-coller intempestif !
Cordialement.