Copie de la valeur de groupe de cellules à coté d'une cellule fusionnée sur format txt

Version imprimable

22/04/2015, 11h38
gabi974

Copie de la valeur de groupe de cellules à coté d'une cellule fusionnée sur format txt

Bonjour,

Mon problème est que je dois copier le résultat de plusieurs cellules appartenant à un même groupe, définis pas une cellule fusionné à leur gauche.

Ce qui fait la spécificité de mon problème est je dois copier des valeurs en Hexadecimal du bit le plus fort au bit le plus faible. Sur mon tableur, il part du bas vers le haut (sur la colonne "C" pour l'exemple ).

Je veux donc écrire sur mon fichier .txt, sur la même ligne, les valeurs hexa du bit le plus fort au plus faible (du bas jusqu'en haut), dans la condision où ma cellule de groupe est fusionné(colonne "B").

Si la condition ne marche pas, je peux utiliser: si la cellule suivante en "B" = cellule actuel "B", alors j'écris mes valeurs à la suite de la dernière colonne du groupe en "C" jusqu'à la première cellule du groupe en "C".

Merci de votre compréhension,

Gabi974

Edit:

Bonjour, je n'ai malheureusement pas de réponse, peut être que j'ai mal écrit, je reformule mon problème:

Je souhaite copier bout à bout des valeurs dans une colonne (en hexa) pour les coller sur une même ligne.(colonne C)
La difficulté est qu'il faut copier du bas vers le haut dans la condition qu'il y ai la même valeur sur la colonne de gauche.(colonne B)

Merci,

gabi974

edit:
Désolé, je up.

Bonjour,

Ci-joint, un code correspondant à ce que j'ai compris de votre problème et qui est indépendant des valeurs hexadécimales se trouvant dans la colonne C. L'important étant de savoir qu'il faut transposer à partir de la fin pour chaque cellule non vide dans la colonne B.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Option Explicit
 
Sub RegrouperLesMesuresSurUneLigne()
 
Dim ShMesures As Worksheet
Dim AireMesures As Range
Dim CelluleMesure As Range
Dim AireDesCellulesHexa As Range
 
Dim DerniereLigne As Long
Dim I As Long
Dim J As Long
 
        Set ShMesures = Sheets("Feuil1")
        With ShMesures
 
            .Range(.Cells(1, 4), .Cells(.UsedRange.Rows.Count, .Columns.Count)).Clear
 
            DerniereLigne = .Cells(.Rows.Count, 2).End(xlUp).Row
 
            Set AireMesures = .Range(.Cells(1, 2), .Cells(DerniereLigne, 2))
 
            For Each CelluleMesure In AireMesures
                If CelluleMesure <> "" Then
                   If CelluleMesure.MergeCells = True Then
                      Set AireDesCellulesHexa = CelluleMesure.MergeArea
                      J = 0
                      For I = AireDesCellulesHexa.Count To 1 Step -1
                            CelluleMesure.Offset(0, 2 + J) = AireDesCellulesHexa.Cells(I, 1).Offset(0, 1)
                            J = J + 1
                      Next I
                      Set AireDesCellulesHexa = Nothing
                   Else
                      CelluleMesure.Offset(0, 2) = CelluleMesure.Offset(0, 1)
                   End If
                End If
            Next CelluleMesure
            Set AireMesures = Nothing
        End With
 
        Set ShMesures = Nothing
 
End Sub

Pièce jointe 175855

Cordialement.

24/04/2015, 08h24
gabi974

Bonjour Eric KERGRESSE,

Merci pour ta réponse, elle est correct, mais j'essai de l'adapter à mon cas:

Depuis le début de ma programmation, j'utilise les range("B"...);
La résultat est sur une ligne d'un fichier de format txt.

Je vais analyser ton code, si ça marche pour mon cas, je résolve le sujet.

cordialment,

gabi974
24/04/2015, 08h43
Invité

Citation:

Envoyé par gabi974

mais j'essai de l'adapter à mon cas:
Depuis le début de ma programmation, j'utilise les range("B"...);
La résultat est sur une ligne d'un fichier de format txt.

C'est difficile de comprendre ton problème sans code joint.

Mets au moins ton code en ligne pour voir comment tu crées ton fichier txt et génères tes lignes dans ce fichier.

Cordialement.

Désolé, je ne peux pas le mettre de suite, je suis sur un autre projet qui n'a rien à voir avec la programmation.

Je te présenterai mon bout de code correspondant à mon problème.

à la prochaine,
gabi974.

EDIT:

Bonjour, voici une partie de mon code, j'ai modifier quelques noms; ect...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
 
 
Dim Imem As Long 'definition des bytes
Dim data(0 To 65536) As Byte
    For Imem = 0 To 65536
        Let data(Imem) = &HFF
    Next Imem
 
'créer un fichier h du nom de nom dossier
nf = FreeFile
    Let filename = Application.GetSaveAsFilename("nom dossier", "nom dossier (*.txt),*.txt", , "fichier")
    If filename = "Falsch" Then Exit Sub
 
 
' ouverture du fichier
Open filename For Output As #nf
 
 
 
For J = 5 To defderniereLigne + 1
 
    If Not IsEmpty(Range("B" & J).value) Then
        'effacer les espaces
        defaddname = LTrim(Range("B" & J).value)
        sansespdefaddname = Split(defaddname, " ")(0)
        'condition : si les cellules sont fusionné
        If Range("B" & J).MergeCells = True Then
            Set AireDesCellulesHexa = Range("B" & J).MergeArea
            L = 0
            For K = AireDesCellulesHexa.Count To 1 Step -1
        'ce que je veux changer, qui me cause problème 
        valeur = Application.WorksheetFunction.CountIf(Range("C" & J + n).variant, Range("C" & J).variant)
        '.Hex2Dec
 
            Print #nf, "#define "; sansespdefaddname; "_INIT "; valeur
        Else
            Print #nf, "#define "; sansespdefaddname; "_INIT "; Application.WorksheetFunction.Hex2Dec(Range("C" & J).value)
        End If
    End If
Next J
 
 
'fermeture du fichier obligatoire
Close (nf)
 
 
End Sub

il manque des Dim, mais c'est juste pour l'exemple.

Cordialement,
gabi974

EDIT:

J'ai oublié de préciser, je ne dois pas modifier ou apporter des valeurs sur le tableau, le résultat doit se faire directement sur le fichier TXT

Bonjour,

En admettant que les cellules de la colonne C contiennent les valeurs hexadécimales, le code pour générer le fichier txt pourrait être celui-là :

Nb :
- Le séparateur de champs est le ;
- les lignes écrivant sur le tableau sont neutralisées.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Sub RegrouperLesMesuresSurUneLigne()
 
Dim ShMesures As Worksheet
Dim AireMesures As Range
Dim CelluleMesure As Range
Dim AireDesCellulesHexa As Range
 
Dim DerniereLigne As Long
Dim I As Long
Dim J As Long
 
Dim FichierTexte As Object
Dim LigneFichierTexte As Object
Dim ContenuLigneFichierTexte As Variant
Dim NomDuFichierTxt As Variant
 
Dim SansEspDefAddName As Variant
 
    ChDir ActiveWorkbook.Path
 
    NomDuFichierTxt = Application.GetSaveAsFilename("nom dossier", "nom dossier (*.txt),*.txt", , "Fichier")
    If NomDuFichierTxt = False Then Exit Sub
 
    Set FichierTexte = CreateObject("Scripting.FileSystemObject")
    Set LigneFichierTexte = FichierTexte.CreateTextFile(NomDuFichierTxt, True)
 
    Set ShMesures = Sheets("Feuil1")
    With ShMesures
 
         '.Range(.Cells(1, 4), .Cells(.UsedRange.Rows.Count, .Columns.Count)).Clear
 
         DerniereLigne = .Cells(.Rows.Count, 2).End(xlUp).Row
         Set AireMesures = .Range(.Cells(1, 2), .Cells(DerniereLigne, 2))
 
         For Each CelluleMesure In AireMesures
             If CelluleMesure <> "" Then
 
                SansEspDefAddName = Split(LTrim(CelluleMesure), " ")(0)
 
                ContenuLigneFichierTexte = SansEspDefAddName & "_INIT;"
                If CelluleMesure.MergeCells = True Then
                   Set AireDesCellulesHexa = CelluleMesure.MergeArea
                   J = 0
                   For I = AireDesCellulesHexa.Count To 1 Step -1
                       ContenuLigneFichierTexte = ContenuLigneFichierTexte & AireDesCellulesHexa.Cells(I, 1).Offset(0, 1) & ";"
                      ' CelluleMesure.Offset(0, 2 + J) = AireDesCellulesHexa.Cells(I, 1).Offset(0, 1)
                      ' J = J + 1
                   Next I
                   ContenuLigneFichierTexte = Mid(ContenuLigneFichierTexte, 1, Len(ContenuLigneFichierTexte) - 1)
                   LigneFichierTexte.writeline (ContenuLigneFichierTexte)
                   Set AireDesCellulesHexa = Nothing
                Else
                   ContenuLigneFichierTexte = ContenuLigneFichierTexte & CelluleMesure.Offset(0, 1)
                   LigneFichierTexte.writeline (ContenuLigneFichierTexte)
                  ' CelluleMesure.Offset(0, 2) = CelluleMesure.Offset(0, 1)
                End If
             End If
        Next CelluleMesure
        Set AireMesures = Nothing
    End With
 
    LigneFichierTexte.Close
 
    Set LigneFichierTexte = Nothing
    Set FichierTexte = Nothing
    Set ShMesures = Nothing
 
End Sub

Cordialement.

Merci Eric,

ton code n'était pas excatement bon, il y avait des erreurs de compilations quand il était dans mon SUB.

J'ai changé le: LigneFichierTexte.writeline (ContenuLigneFichierTexte)
par : Print #nf, ContenuLigneFichierTexte

et quelques autres petits points que j'ai corrigé à ma façon:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Dim ShMesures As Worksheet
Dim AireMesures As Range
Dim CelluleMesure As Range
Dim AireDesCellulesHexa As Range
 
Dim def2derniereligne As Long
 
Dim FichierTexte As Object
Dim LigneFichierTexte As Object
Dim ContenuLigneFichierTexte As Variant
Dim NomDuFichierTxt As Variant
 
Dim K As Long
 
Set AireMesures = Range(Range("B" & J + 5), Cells(defderniereLigne, 2))
 
         For Each defaddname In AireMesures
             If defaddname <> "" Then
 
                SansEspDefAddName = Split(LTrim(defaddname), " ")(0)
 
                ContenuLigneFichierTexte = SansEspDefAddName & "_INIT;"
         If defaddname.MergeCells = True Then
                   Set AireDesCellulesHexa = defaddname.MergeArea
                   J = 0
                   For K = AireDesCellulesHexa.Count To 1 Step -1
                       ContenuLigneFichierTexte = ContenuLigneFichierTexte & AireDesCellulesHexa.Cells(K, 1).Offset(0, 1) & ";"
                      ' CelluleMesure.Offset(0, 2 + J) = AireDesCellulesHexa.Cells(I, 1).Offset(0, 1)
                      ' J = J + 1
                   Next K
                   ContenuLigneFichierTexte = Mid(ContenuLigneFichierTexte, 1, Len(ContenuLigneFichierTexte) - 1)
                   Print #nf, ContenuLigneFichierTexte
                   Set AireDesCellulesHexa = Nothing
                Else
                   ContenuLigneFichierTexte = ContenuLigneFichierTexte & defaddname.Offset(0, 1)
                   Print #nf, ContenuLigneFichierTexte
                  ' CelluleMesure.Offset(0, 2) = CelluleMesure.Offset(0, 1)
                End If
             End If
        Next defaddname
        Set AireMesures = Nothing

Je n'avait pas besoin de plus, sinon ça ne marcherai pas (soit c'était déjà défini comme pour l'enregistrement; l'ouverture et fermeture du fichier.)

Comme je ne suis pas 100% sûr du résultat, je vais chercher s'il y a des problèmes par échantillonnage, et dés que je pense que c'est bon, je révolve le topic

Maintenant, après avoir extrais mes valeurs hexa, je décide de les convertir en décimal dans ce code:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Dim ShMesures As Worksheet
Dim AireMesures As Range
Dim CelluleMesure As Range
Dim AireDesCellulesHexa As Range
 
Dim def2derniereligne As Long
 
Dim FichierTexte As Object
Dim LigneFichierTexte As Object
Dim ContenuLigneFichierTexte As Variant
Dim NomDuFichierTxt As Variant
Dim defvaleur As Variant
Dim def2valeur As Variant
 
Dim K As Long
 
Set AireMesures = Range(Range("B" & J + 5), Cells(defderniereLigne, 2))
 
         For Each defaddname In AireMesures
             If defaddname <> "" Then
 
                SansEspDefAddName = Split(LTrim(defaddname), " ")(0)
 
                ContenuLigneFichierTexte = "#define " & SansEspDefAddName & "_INIT;"
         If defaddname.MergeCells = True Then
                   Set AireDesCellulesHexa = defaddname.MergeArea
                   Set defvaleur = defaddname.MergeArea
                   J = 0
                   For K = AireDesCellulesHexa.Count To 1 Step -1
                       ContenuLigneFichierTexte = ContenuLigneFichierTexte & AireDesCellulesHexa.Cells(K, 1).Offset(0, 1)
                      ' CelluleMesure.Offset(0, 2 + J) = AireDesCellulesHexa.Cells(I, 1).Offset(0, 1)
                      ' J = J + 1
                   Next K
                   ContenuLigneFichierTexte = Mid(ContenuLigneFichierTexte, 1, Len(ContenuLigneFichierTexte))
                   'extraction des valeurs hexa pour convertir en decimal
                   defvaleur = Split(ContenuLigneFichierTexte, ";")(1)
                   Application.WorksheetFunction.Hex2Dec (defvaleur)
 
                   Print #nf, defvaleur
                   Set AireDesCellulesHexa = Nothing
 
                Else
                   ContenuLigneFichierTexte = ContenuLigneFichierTexte & defaddname.Offset(0, 1)
                   Print #nf, ContenuLigneFichierTexte
                  ' CelluleMesure.Offset(0, 2) = CelluleMesure.Offset(0, 1)
                End If
             End If
        Next defaddname
        Set AireMesures = Nothing

Il compile correctement, mais il bute sur cette valeur hexa: 00000000000000000051
Normalement il devrai m'afficher 81, mais il m'affiche "Erreur d'execution '1004' La méthode Hex2dec de la classe WorksheetFunction à échoué"

help

27/04/2015, 16h59
Invité

Citation:

Envoyé par gabi974

Il compile correctement, mais il bute sur cette valeur hexa: 00000000000000000051
Normalement il devrai m'afficher 81, mais il m'affiche "Erreur d'execution '1004' La méthode Hex2dec de la classe WorksheetFunction à échoué"

Il vous faut mettre un fichier en ligne pour reproduire votre problème.

Cordialement.
27/04/2015, 22h39
SfJ5Rpw8

bonsoir,

non pas besoin de fichier, il suffit de lire le message d'erreur et de consulter l'aide en ligne de HexDec ...

Citation:

Envoyé par Aide en ligne

HEXDEC(nombre)

nombre représente le nombre hexadécimal à convertir. L'argument nombre ne peut pas comporter plus de 10 caractères (40 bits). Le bit poids fort de nombre est le bit de signe. Les 39 autres bits sont des bits de grandeur. Les nombres négatifs sont représentés à l'aide de la notation de complément à 2.

Note

Si l'argument nombre n'est pas un nombre hexadécimal valide, HEXDEC renvoie la valeur d'erreur #NOMBRE!

il y as un peu trop de 0 dans ta chaîne :

Code:

.... WorksheetFunction.Hex2Dec(Right("0000000000000051",10)) ...
28/04/2015, 02h39
Invité

Bien vu Bbil.

Cordialement.
28/04/2015, 08h31
gabi974

Citation:

Envoyé par Eric KERGRESSE

Il vous faut mettre un fichier en ligne pour reproduire votre problème.

Cordialement.

Je ne peux malheureusement pas, le tableur reste confidentiel à mon entreprise, je peux en revanche donner quelques formules et résultats.

les résultats en hexa ressemble à :
00000000000000000051
0032
001E
0071
03E8
0071
001E
5A0D
FFFF
FFFB
FFFEFFFFFFFFFFFF9FF1FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFFFFFFFE
0009CC11
00000000
FFFFFFFFFFFFFFFF
4704000000000037
FFFFFF05FFFFFFFF

Je n'arrive pas à faire fonctionner le: WorksheetFunction.Hex2Dec (Right("0000000000000051", 10))
et j'ai oublier de préciser ma version excel (2010)

Bonjour,

La transformation en décimal ne devrait-elle pas se situer dans la boucle For K next ? C'est à dire avant d'être concaténée dans la ligne.

Code:

1
2
3
4
5
6
7
8
9
 
         For K = AireDesCellulesHexa.Count To 1 Step -1
                     ' ici 
                       defvaleur = WorksheetFunction.Hex2Dec (AireDesCellulesHexa.Cells(K, 1).Offset(0, 1))
                       ContenuLigneFichierTexte = ContenuLigneFichierTexte & defvaleur & ";"
 
                    ' au lieu de
                    '   ContenuLigneFichierTexte = ContenuLigneFichierTexte & AireDesCellulesHexa.Cells(K, 1).Offset(0, 1)
        Next K

Pourquoi, n'y a-t-il plus de séparateur de champs après chaque valeur ?

Cordialement.

28/04/2015, 10h30
gabi974

Citation:

Envoyé par Eric KERGRESSE

Pourquoi, n'y a-t-il plus de séparateur de champs après chaque valeur ?.

(EDIT) J'ai besoin que mes valeurs soient collé, et j'ajoute après le "0x..." pour que le soft qui lit le fichier puisse comprendre.

(je laisse cette explication pour les visiteurs qui souhaite comprendre)
La valeur Hexa en 4 chiffres représente une valeur qui a un bit le plus faible suivis de son bit le plus fort.

ça formule en décimale est par exemple : 20(bit le plus fort) x 256 + 10(bit le plus faible) = (calculatrice en main) 5130

on convertis nos valeurs d'entrées en hexa:
20 dec = 14 hexa
10 dec = 0A hexa

en écrivant simplement du bit le plus fort au bit le plus faible : 140A
On obtient après conversion Hex2Dec : 5130

est plus on rajoute des valeurs hexa, plus dans le calcul en décimale on multiplie par 256:

06FFFF --> 06*256*256 + 255 * 256 + 255
(255=valeur de FF)

D'où la nécessité de retirer les espaces et d'avoir mes valeurs dans l'ordre voulue

EDIT:

Je crois ne pas avoir répondus à la question, peut être que vous connaissez déjà la réponse que j'ai donnée, mais au finale, la phrase suivante va peut être vous rendre furieux:

Je ne suis pas obliger à convertir en décimale, je viens de recevoir l'ordre il y a un instant la consigne de mon colègue qui s'occupe de la gestion de ce projet.

En partant du principe que nous avons résolus jusqu'à la conversion, je mets le sujet en résolus.

Et encore Merci Eric et Bbil de vos aides,

à la prochaine,

gabi974

PS: +1 à chaque post