Dispatcher une colonne vers deux onglets

[st007]

Bonjour à toutes et à tous,

Je cherche à répartir les données de la feuil1 dans les onglets Fluoro et Graphie

une future ligne est déterminée par la ligne comportant "Irradiation Event X-Ray Data" (ligne 38,98,158 par exemple et non régulier)
l'onglet de destination est déterminé par la ligne comportant "Irradiation Event type" (ligne 42,102,702)
fluoroscopy --->fluoro
vide ----->Graphie (série commençant en ligne 698, Graphie Lisse en ligne 705 par exemple)

Les colonnes de destination ne comporteront au final aucune unité

J'ai bien trouvé une macro (TEST), qui me remet mes données en ligne, mais je ne la comprends pas et donc ne suis pas capable de l'adapter, car il y a de petites différences dans les données et un décalage de colonne...

une autre approche ou une grosse lumière me serait d'un grand secours

merci d'avance....

 

[Modeste]

Re : Dispatcher une colonne vers deux onglets

Salut st007,

Plein d'allant ce soir, je me suis attaqué à ton fichier ... puis j'ai déchanté un peu: c'est monstrueux!

Finalement, au bout d'un temps considérable, je croyais avoir trouvé: le décalage vers le bas, au départ de chaque "Irradiation Event X-Ray Data" est différent pour les Fluoro et les Graphie ... et bien, ce n'est pas fini: ces décalages ne sont même pas identiques d'un "groupe de cellules" à l'autre!

Trop tard et trop "tarabiscoté" pour moi! Je vais me coucher!

 

[Modeste]

Re : Dispatcher une colonne vers deux onglets

Bonjour st007, le forum,

À force, j'ai fini par arriver à un résultat ... qui ressemble à quelque chose (je te laisse vérifier la pertinence des résultats obtenus )

Le code suivant est à placer dans un module standard:

Sub autre()
Application.ScreenUpdating = False
With Sheets("Feuil1")
tabloTitres = Array("DateTime Started:", "Dose Area Product:", "Dose (RP):", "Positioner Primary Angle:", "Positioner Secondary Angle:", "Collimated Field Area:", "KVP:", "X-Ray Tube Current:", "Exposure Time:", "Distance Source to Detector:", "Distance Source to Isocenter:", "Table Height Position:")
derLigne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Set irrad = .[A:A].Find(what:="Irradiation Event X-Ray Data", LookIn:=xlValues, lookat:=xlWhole)
If Not irrad Is Nothing Then premAdr = irrad.Address
Do
    If irrad.Offset(4, 0) Like "*Fluoroscopy*" Then
        Set f = Sheets("Fluoro")
    Else
        Set f = Sheets("Graphie")
    End If
    nouvLigne = f.Cells(.Rows.Count, 1).End(xlUp).Row + 1
    For titre = 0 To UBound(tabloTitres)
        On Error GoTo fin
        toto = Application.Match(tabloTitres(titre), .Cells(irrad.Row, 1).Resize(derLigne - irrad.Row, 1), 0) + irrad.Row
        f.Cells(nouvLigne, titre + 1) = .Cells(toto, 1)
    Next titre
    Set irrad = .[A:A].FindNext(irrad)
Loop While Not irrad Is Nothing And irrad.Address <> premAdr
fin:
End With
Application.ScreenUpdating = True
End Sub

Je n'ai pas cherché à gérer tous les cas d'erreurs possibles, même si je crains qu'il faille s'y intéresser un jour!?
Je n'ai ajouté une sortie anticipé que parce que dans ton fichier, figurait une mention "Irradiation Event X-Ray Data" en toute dernière ligne (sans plus rien en-dessous )

Teste dans le fichier que tu avais déposé (en effaçant dans les 2 feuilles, la ligne que tu y avais complétée "à la main" ... ou conserve-les, pour vérifier si la première ligne qui s'ajoutera sera bien identique)

... et dis-nous si ça "roule"

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Bonjour Modeste,
Sur les véritables imports, il n'y a pas de dernière ligne ou figure une mention "Irradiation Event X-Ray Data" sans rien en dessous,
je l'avais ajouté manuellement pour faire tourner la macro Test (honte à moi d'avoir oublier)

Le résultat est tout à fait pertinent de "j u s t e s s e" et de rapidité.

Bien sûre, dans l'onglet "Fluoro" ligne 155 à 158 l'idée est de garder que la valeur précédent "ms" qui sont des mili secondes pour info

je vais essayer de digérer ta macro pour essayer de comprendre ces fameux tablo et surtout n'arriver à garder que les valeurs sans unités.
j'ai trouvé cette macro de Job75 qui fait un super boulot pour une colonne réécrite dans une autre sans unités

Sub SEPARE()
Dim r As Range, t(), i&
Set r = Range("D1:D2" & [D65536].End(xlUp).Row) 'au moins 2 cellules
ReDim t(1 To r.Count, 1 To 1) 'tableau, plus rapide
t(1, 1) = r(1)
For i = 2 To UBound(t)
  If Trim(r(i)) Like "#*" Then t(i, 1) = Val(r(i).Text)
Next
With [E1].Resize(UBound(t))
  .Value = t
  '.SpecialCells(xlCellTypeBlanks).Delete xlUp 'supprime les cellules vides
End With
End Sub

mais je souhaiterais çà pour toutes les colonnes B:L de mes onglets fluoro et graphie,
je creuse donc et te remercie encore une fois pour ta réponse et ta disponibilité

 

[Modeste]

Re : Dispatcher une colonne vers deux onglets

Re,

Je ne sais pas si tu préférais chercher tout seul ... si c'est le cas, ne lis pas ce qui suit

J'ai supprimé la seule gestion d'erreur, puisque la dernière ligne était une erreur
En première colonne, tu auras de vraies dates, dans les suivantes, des valeurs numériques "pures" (pour le séparateur décimal, j'ai remplacé les '.' par des ',' ... tu diras si c'était utile ou non)

Sub autre()
Application.ScreenUpdating = False
With Sheets("Feuil1")
tabloTitres = Array("DateTime Started:", "Dose Area Product:", "Dose (RP):", "Positioner Primary Angle:", "Positioner Secondary Angle:", "Collimated Field Area:", "KVP:", "X-Ray Tube Current:", "Exposure Time:", "Distance Source to Detector:", "Distance Source to Isocenter:", "Table Height Position:")
derLigne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Set irrad = .[A:A].Find(what:="Irradiation Event X-Ray Data", LookIn:=xlValues, lookat:=xlWhole)
If Not irrad Is Nothing Then premAdr = irrad.Address
Do
    If irrad.Offset(4, 0) Like "*Fluoroscopy*" Then
        Set f = Sheets("Fluoro")
    Else
        Set f = Sheets("Graphie")
    End If
    nouvLigne = f.Cells(.Rows.Count, 1).End(xlUp).Row + 1
    For titre = 0 To UBound(tabloTitres)
        toto = Application.Match(tabloTitres(titre), .Cells(irrad.Row, 1).Resize(derLigne - irrad.Row, 1), 0) + irrad.Row
        If titre = 0 Then
            valeurDate = CDate(.Cells(toto, 1))
        Else
            valeurAutre = Replace(Split(.Cells(toto, 1), " ")(0), ".", ",")
        End If
        f.Cells(nouvLigne, titre + 1) = IIf(titre = 0, valeurDate, CDbl(valeurAutre))
    Next titre
    Set irrad = .[A:A].FindNext(irrad)
Loop While Not irrad Is Nothing And irrad.Address <> premAdr
End With
Application.ScreenUpdating = True
End Sub

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Re,

par politesse, j'ai lu et pffffffffff!!!
çà fonctionne en plus grrrrrrr!!!

j'utilise habituellement le point comme séparateur de décimales comme ce logiciel osirix d'où est tiré cet import, donc pour le fun, je vais essayer de bidouiller ton "replace"

je suis encore bien loin d'une telle maîtrise du vba ....
mais faut vraiment que je comprenne le fonctionnement car je vais peut-être devoir ajouter des colonnes à rapatrier, ou bien sûre les prochains imports n'auront pas la même présentation bref on en fini jamais ....

en tout cas, grand merci et bon 15 août surtout si tu es du côté de Liège par exemple ...

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Bonjour, ce génialissime forum
Je souhaiterais extraire le nombre à trois chiffres suivant "iiDiameter SRData="260" en ligne 152 pour le premier

l'idée serait de concatener ou de fusionner les cellules depuis " comment:" jusqu'à "device role in procedure:"
Mes essais en sont :
En les concatenant en A1, j'obtiens ce que je veux avec une formule :

=GAUCHE(DROITE(A1;CHERCHE("iiDiameter";A1)-10);3)*1

mais automatiser l'extraction est bien au-delà de ma compétence
je me prends la tête avec ce genre de procédure ....

Sub Macro1()
With Sheets("Feuil1")
'Dim derligne
Set deb = .[A:A].Find(what:="Comment:", LookIn:=xlValues, lookat:=xlWhole)
d = deb.Row
Set fin = .[A:A].Find(what:="Device Role in Procedure:", LookIn:=xlValues, lookat:=xlWhole).Offset(-1, 0)
F = fin.Row
Range("d1").Value = ""
For i = d To F
Range("d" & i).Value = Range("a" & d).Value & Range("A" & i).Value
Next i
End With
End Sub

une lumière pour m'éclairer .....???

Merci d'avance.

 

[Staple1600]

Re : Dispatcher une colonne vers deux onglets

Bonsoir à tous

Je souhaiterais extraire le nombre à trois chiffres suivant "iiDiameter SRData="260" en ligne 152 pour le premier

Personnellement pour faire cela je suivra cette voie:

Données/Convertir/Délimité/Séparateur [X] Autre : =

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Bonsoir Staple 1600,

Je retiens ton idée, plutôt sympa au demeurant,
et c'est là qu'arrive le "mais" en ligne 259, 260
Je veux retrouver le 260 en ligne 260 alors que iidiameter est en ligne 259, d'où l'idée de concatener les cellules de 256 "Comment:" à 263 "Device Role in procedure:" dans une autre colonne (j'avais pris d au hasard) pour utiliser la formule

=GAUCHE(DROITE(D1;CHERCHE("iiDiameter";D1)-10);3)*1

En français, je dirais
parcourir la colonne A jusqu'à trouver "comment:"
concatener les lignes jusqu'à la ligne contenant "Device Role in procedure:"
en réécrivant la concaténation en colonne "d" à partir de d1, je viendrai par la suite coller ma formule en colonne "e" étirée du nombre de ligne que comprendra la colonne "d" et j'aurai mon "graal"
une particularité cependant est qu'en bas de colonne A, on trouve un "comment:" non suivi de "device role in procedure" dont je n'ai que faire bien sure.

aurais-je une procédure inenvisageable ?
en tout cas, merci de m'avoir lu .

 

[Staple1600]

Re : Dispatcher une colonne vers deux onglets

Re

En étant pas sur d'avoir tout compris, vois si le code ci-dessous peut t'inspirer quelque idée

Sub a()
Dim i&, j&, t$
j = 1
On Error Resume Next
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, "A") Like "Comment:" Then
t = Cells(i, "A")(1) & Cells(i, "A")(2) & Cells(i, "A")(3)
MsgBox CDbl(Trim(Replace(Split(Split(t, ">")(8), """")(1), ".", ","))) * 1
'décommentes la ligne ci-dessous pour mettre les valeurs en colonne B
'Cells(j, "B").Value = CDbl(Trim(Replace(Split(Split(t, ">")(8), """")(1), ".", ","))) * 1
j = j + 1
End If
Next i
End Sub

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Bonsoir,
Merci Staple1600 pour cette source d'inspiration ...
je crois que je vais parvenir à mes fins...

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Bonsoir,
un autre formatage de données, et je ne parviens pas à modifier le code en conséquence ....

Sub autre()
Application.ScreenUpdating = False
With Sheets("Feuil1")
tabloTitres = Array("DateTime Started:", "Dose Area Product:", "Dose (RP):", "Positioner Primary Angle:", "Positioner Secondary Angle:", "Collimated Field Area:", "KVP:", "X-Ray Tube Current:", "Exposure Time:", "Distance Source to Detector:", "Distance Source to Isocenter:", "Table Height Position:")
derLigne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Set irrad = .[A:A].Find(what:="Irradiation Event X-Ray Data", LookIn:=xlValues, lookat:=xlWhole)
If Not irrad Is Nothing Then premAdr = irrad.Address
Do
    If irrad.Offset(4, 0) Like "*Fluoroscopy*" Then  ' ici désormais 49 au lieu de 4
        Set f = Sheets("Fluoro")
    Else
        Set f = Sheets("Graphie")
    End If
    nouvLigne = f.Cells(.Rows.Count, 1).End(xlUp).Row + 1
    For titre = 0 To UBound(tabloTitres)
        toto = Application.Match(tabloTitres(titre), .Cells(irrad.Row, 1).Resize(derLigne - irrad.Row, 1), 0) + irrad.Row
        If titre = 0 Then
            valeurDate = CDate(.Cells(toto, 1))
        Else
            valeurAutre = Replace(Split(.Cells(toto, 1), " ")(0), ".", ",")
        End If
        f.Cells(nouvLigne, titre + 1) = IIf(titre = 0, valeurDate, CDbl(valeurAutre))
    Next titre
    Set irrad = .[A:A].FindNext(irrad)
Loop While Not irrad Is Nothing And irrad.Address <> premAdr
End With
Application.ScreenUpdating = True
End Sub

donc j'ai désormais :
49 lignes entre "Irradiation Event X-Ray Data" et "Irradiation Event Type: Fluoroscopy"
mais 3 lignes entre "datetime started" et sa valeur
et 12 lignes entre les champs définis en array et leurs valeurs
help modeste ....

 

[Modeste]

Re : Dispatcher une colonne vers deux onglets

Salut,

Replonger, là comme ça, dans ce bout de code, ça va me gâcher la digestion
Un extrait de fichier représentatif de la situation actuelle, ce n'est pas envisageable? (ça aiderait sans doute à comprendre tes histoires de 49 lignes ou 3 ou 12 )

 

[st007]

Re : Dispatcher une colonne vers deux onglets

Bonsoir,

j'ai considérablement allégé le nombre de lignes du fichier, (ne passe plus en .xls)

je ne maitrise pas le array et le match comme tu peux t'en douté, je ne comprends pas comment dans l'autre macro, tu prenais la valeur offset(1, 0) de l'intitulé de la colonne. Alors l'adapter ....

le texte et les valeurs à recueillir sont les mêmes, mais elles se sont éloignées ...
pour savoir dans quel onglet on recopie çà se trouve 49 lignes après le "Irradiation Event X-Ray Data"

si ta macro est modifiable, tant mieux, si pas, autant de boucles que de colonne à remplir ?

je ne me préoccupe plus des unités pour les valeurs, puisque plus accolées, mais si on pouvais garder la date ...(aaaammjjhhmmss,000)

 

[Modeste]

Re : Dispatcher une colonne vers deux onglets

Salut st007,

Un seul "mot" me vient: "Groumpfff"
Je croyais n'avoir à adapter qu'une vague histoire de n° de lignes ... mais ce n'était que la partie "aérienne" de l'iceberg

• Dans la colonne A, les "titres" étaient suivis d'un double point, dans la version précédente; plus maintenant. Il faut donc les supprimer du Array tabloTitres
• Tu as ajouté une colonne "Irradiation Event Type" en colonne B de tes 2 feuille "Fluoro" et "Graphie". Son emplacement est définitif? (ou elle pourrait figurer en colonne A? ...ou encore c'était juste pour m'aider à comprendre et elle ne figurera pas dans la version définitive?)
• Il y a (au moins) un des titres "Collimated Field Area" qui n'apparaît plus en colonne A de la Feuil1 ... est-ce que tu l'as supprimé pour alléger le fichier (mais il est toujours présent dans ton vrai fichier), a-t-il disparu définitivement ou -hypothèse nettement moins favorable- est-il parfois présent, parfois pas?
• Dans le même ordre d'idée, y a-t-il d'autres titres qui risquent de poser le même type de problème?
• Les dates et heures des "DateTime Started:" que tu évoquais dans ton dernier message, il faut les convertir en vraies dates et heures ou les récupérer sous leur forme actuelle? On remplace le point par une virgule?

Dans le "jeu des 7 différences" je me suis arrêté là Je sais donc que je n'ai pas gagné le concours, mais peux-tu prendre le temps de vérifier et de répondre aux questions ci-dessus, avant que je ne poursuive?

Question à 2 euros: tu risques d'avoir régulièrement des changements de structure et de formats, comme ici? Si oui, il va falloir que je commente généreusement le code (j'ai déjà noté que je devrais le faire pour le Array et le Match)

PS: pour alléger ton fichier, il vaut mieux, en général, supprimer complètement des lignes et/ou colonnes, plutôt qu'effacer simplement leur contenu. Dans ton dernier fichier, positionne-toi en A1 et appuie sur Ctrl+End ... tu vas comprendre

À plus tard