Autres Organiser des données sur VBA

KManu

XLDnaute Nouveau
Bonjour à tous,

je suis face une difficulté et j'ai un délai très court pour trouver une solution.
Je souhaite organiser des données transmises par un capteur.
Le transfert des fichiers du capteur à mon outils numérique récepteur est désorganisé de la sorte:
exemple:
100.42,0.00,26.17,100.38,0.00,26.18,100.34,0.00,26.22,100.40, (Ligne 1)
0.00,26.22,100.39,0.00,26.20,100.41,0.00,26.20,100.38, (Ligne 2)
0.00,26.19,100.34,0.00,26.19, (..............)
100.45,0.00,26.19,100.34, (..............)
0.00,26.19,100.41,0.00,26.19,100.39, (..............)
0.00,26.22,100.44,0.00,26.22,100.38,0.00,26.19,100.39, (Ligne n)

En gros, on a l'heure de mesure, le débit (00,0), la Température (26 °c en moyenne) et la pression (100 kpa en moyenne).

comment pourrais-je écrire mon code VBA pour obtenir afin d'avoir 3 colonnes (une pour chaque paramètre) et que sur une ligne de plus de 3 données, les valeurs suivantes soient reportées sur une ligne inférieure (insérée) et également par lot de 3 . Un exemple, si je considère la Ligne 1, j'obtiendrais:
0.00, 26.17, 100.38,
0.00, 26.18, 100.34, (ligne insérée et couper/coller des 3 données à la suite des 3 premières)
0.00, 26.22, 100.40, (ligne insérée et couper/coller des 3 données à la suite des 3 secondes)

Merci à tous.
Je tiens à signaler que je travaille sur d'autres logiciels, et que concernant VBA je suis actuellement en train de m'autoformer.
 
Solution
re,

Code modifié, un peu plus rapide

Cordialement, @+
VB:
Sub Import_donnees()
    Dim Tablo, Tablo2$, Tablo3$(), Val_Tab$, x&, y&, z&, i&, Nom_Fichier$
    With Application.FileDialog(msoFileDialogFilePicker)
        .ButtonName = "Lire"
        .AllowMultiSelect = False
        .Title = "Choisissez le fichier à importer"
        .Filters.Clear
        .Filters.Add "Extraction données", "*.txt; *.txt", 1
        .Show
        If .SelectedItems.Count > 0 Then
            Nom_Fichier = .SelectedItems(1)
        Else
            MsgBox "Aucun fichier sélectionné", vbOKOnly + vbInformation, "Information"
            Exit Sub
        End If
    End With
    Workbooks.OpenText Filename:=Nom_Fichier, Origin:=xlMSDOS, _
        StartRow:=1...

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Kmanu et bienvenu sur XLD,
Essayez toujours de fournir un fichier test, c'est plus simple, plus parlant, et permet de faire un VBA mieux ciblé. :)
En PJ un essai avec :
VB:
Sub Transfert()
    Dim i%, Ligne%, Chaine$, tablo
    Application.ScreenUpdating = False
    On Error GoTo Fin
    ' On concatène toutes les données en une seule chaine
    For i = 1 To Sheets("Feuil1").Range("A65500").End(xlUp).Row
        Chaine = Chaine & Sheets("Feuil1").Cells(i, "A")
    Next i
    ' On splite cette chaine avec la virgule comme séparateur
    tablo = Split(Chaine, ",")
    Ligne = 1
    With Feuil2
        ' On efface la feuille 2
        .Range("A:C").ClearContents
        ' On redistribue les données
        For i = 1 To UBound(tablo) Step 3
            .Cells(Ligne, "A") = tablo(i)
            .Cells(Ligne, "B") = tablo(i + 1)
            .Cells(Ligne, "C") = tablo(i + 2)
            Ligne = Ligne + 1
        Next i
    End With
Fin:
    Application.ScreenUpdating = True
End Sub
Les données sont en feuille 1, le résultat en feuille 2.
 

Pièces jointes

  • Kmanu.xlsm
    16.6 KB · Affichages: 2

KManu

XLDnaute Nouveau
Bonjour Kmanu, le forum

Avec un fichier de test, cela serait mieux ! les données sont précisément stockées en c ellules comme tu l'indiques ?

Cordialement, @+
Bonjour Kmanu, le forum

Avec un fichier de test, cela serait mieux ! les données sont précisément stockées en cellules comme vous l'indiquez ?

Cordialement, @+
Bonjour Yeahou,
merci bcp pour le retour prompt.
Justement, les données sont plus ou moins bien stockées en cellules.
Je joins un fichier exemple.
Déjà, je me pose la question de savoir si VBA est le bon outils à mon problème.

Bien cordialement
KManu
 

Pièces jointes

  • exemple.xlsm
    27.5 KB · Affichages: 2

KManu

XLDnaute Nouveau
Bonjour Kmanu et bienvenu sur XLD,
Essayez toujours de fournir un fichier test, c'est plus simple, plus parlant, et permet de faire un VBA mieux ciblé. :)
En PJ un essai avec :
VB:
Sub Transfert()
    Dim i%, Ligne%, Chaine$, tablo
    Application.ScreenUpdating = False
    On Error GoTo Fin
    ' On concatène toutes les données en une seule chaine
    For i = 1 To Sheets("Feuil1").Range("A65500").End(xlUp).Row
        Chaine = Chaine & Sheets("Feuil1").Cells(i, "A")
    Next i
    ' On splite cette chaine avec la virgule comme séparateur
    tablo = Split(Chaine, ",")
    Ligne = 1
    With Feuil2
        ' On efface la feuille 2
        .Range("A:C").ClearContents
        ' On redistribue les données
        For i = 1 To UBound(tablo) Step 3
            .Cells(Ligne, "A") = tablo(i)
            .Cells(Ligne, "B") = tablo(i + 1)
            .Cells(Ligne, "C") = tablo(i + 2)
            Ligne = Ligne + 1
        Next i
    End With
Fin:
    Application.ScreenUpdating = True
End Sub
Les données sont en feuille 1, le résultat en feuille 2.
Bonjour Sylvanu,
merci pour le retour.
Bien noté, je joins un fichier exemple.
Je vais essayer de comprendre puis de lancer le code que vous m'avez partagé.
Merci.
Bien cordialement ,
Kmanu
 

KManu

XLDnaute Nouveau
Re,
On dirait des données déjà importées et (mal) transformées, vous n'avez pas un fichier brut d'export en txt ou csv ?
Ce serait plus simple de partir directement de la source
Re,
je joins un fichier txt.

Justement, la désorganisation des données est déjà présente sur le fichier brute.
Pour avoir les données de mon capteur j'ai écris un code sur l'hyperTerminal de mon PC, code qui pars chercher les données voulues
( en fait le capteur ne fais que lire la mesure sans faire migrer les données vers un outils numérique).

Bien cordialement
KManu
 

Pièces jointes

  • 2021-11-04_0049.txt
    5.9 KB · Affichages: 5

KManu

XLDnaute Nouveau
Bonjour Kmanu et bienvenu sur XLD,
Essayez toujours de fournir un fichier test, c'est plus simple, plus parlant, et permet de faire un VBA mieux ciblé. :)
En PJ un essai avec :
VB:
Sub Transfert()
    Dim i%, Ligne%, Chaine$, tablo
    Application.ScreenUpdating = False
    On Error GoTo Fin
    ' On concatène toutes les données en une seule chaine
    For i = 1 To Sheets("Feuil1").Range("A65500").End(xlUp).Row
        Chaine = Chaine & Sheets("Feuil1").Cells(i, "A")
    Next i
    ' On splite cette chaine avec la virgule comme séparateur
    tablo = Split(Chaine, ",")
    Ligne = 1
    With Feuil2
        ' On efface la feuille 2
        .Range("A:C").ClearContents
        ' On redistribue les données
        For i = 1 To UBound(tablo) Step 3
            .Cells(Ligne, "A") = tablo(i)
            .Cells(Ligne, "B") = tablo(i + 1)
            .Cells(Ligne, "C") = tablo(i + 2)
            Ligne = Ligne + 1
        Next i
    End With
Fin:
    Application.ScreenUpdating = True
End Sub
Les données sont en feuille 1, le résultat en feuille 2.
Re Sylvanu,

Merci encore!!
le code fonctionne très bien! (il demande juste que les données soient brutes, pas convertion préalable sur Excel).
J'avais une question de compréhension par contre: le "UBound" j'ai du al a bien saisir sa fonction

Bien Cordialement
KManu
 

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Re, bonjour sylvanu

Comme c'est fait, je poste ma proposition.
Lancer la macro par le bouton (ou directement) et choisir le fichier à importer

Bien cordialement, @+
VB:
Sub Import_donnees()
    Dim Tablo, Tablo2$, Tablo3$(), x&, y&, z&, i&, Nom_Fichier$
    With Application.FileDialog(msoFileDialogFilePicker)
        .ButtonName = "Lire"
        .AllowMultiSelect = False
        .Title = "Choisissez le fichier à importer"
        .Filters.Clear
        .Filters.Add "Extraction données", "*.txt; *.txt", 1
        .Show
        If .SelectedItems.Count > 0 Then
            Nom_Fichier = .SelectedItems(1)
        Else
            MsgBox "Aucun fichier sélectionné", vbOKOnly + vbInformation, "Information"
            Exit Sub
        End If
    End With
    Workbooks.OpenText Filename:=Nom_Fichier, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), Array(4, _
        9), Array(14, 2)), TrailingMinusNumbers:=True
    Columns("B:B").Replace What:="OK", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula
    Tablo = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row).Value2
    y = LBound(Tablo): z = UBound(Tablo)
    For x = y To z
        If (InStr(1, Tablo(x, 1), ",") > 0 Or InStr(1, Tablo(x, 1), ".") > 0 Or IsNumeric(Tablo(x, 1))) And (IsNumeric(Left(Tablo(x, 1), 1)) Or Left(Tablo(x, 1), 1) = "." Or Left(Tablo(x, 1), 1) = ",") Then
            Tablo2 = Tablo2 & Tablo(x, 1)
        End If
        If Not Tablo2 = "" Then If Left(Tablo(x, 1), 1) = "P" And IsNumeric(Mid(Tablo(x, 1), 2, 1)) Then Tablo2 = Tablo2 & ","
    Next x
    Columns("A:B").ClearContents
    Columns("A:C").NumberFormat = "@"
    Tablo = Split(Tablo2, ",")
    ReDim Tablo3(1 To Application.WorksheetFunction.RoundUp((UBound(Tablo) - LBound(Tablo) + 1) / 3, 0), 1 To 3)
    i = LBound(Tablo)
    For x = LBound(Tablo) To UBound(Tablo) Step 3
        i = i + 1
        Tablo3(i, 1) = Tablo(x)
        Tablo3(i, 2) = Tablo(x + 1)
        Tablo3(i, 3) = Tablo(x + 2)
    Next x
    Range("A1:C" & UBound(Tablo3, 1)).Value2 = Tablo3
End Sub
 

Pièces jointes

  • Test_Import.xlsm
    22 KB · Affichages: 1

KManu

XLDnaute Nouveau
Re, bonjour sylvanu

Comme c'est fait, je poste ma proposition.
Lancer la macro par le bouton (ou directement) et choisir le fichier à importer

Bien cordialement, @+
VB:
Sub Import_donnees()
    Dim Tablo, Tablo2$, Tablo3$(), x&, y&, z&, i&, Nom_Fichier$
    With Application.FileDialog(msoFileDialogFilePicker)
        .ButtonName = "Lire"
        .AllowMultiSelect = False
        .Title = "Choisissez le fichier à importer"
        .Filters.Clear
        .Filters.Add "Extraction données", "*.txt; *.txt", 1
        .Show
        If .SelectedItems.Count > 0 Then
            Nom_Fichier = .SelectedItems(1)
        Else
            MsgBox "Aucun fichier sélectionné", vbOKOnly + vbInformation, "Information"
            Exit Sub
        End If
    End With
    Workbooks.OpenText Filename:=Nom_Fichier, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), Array(4, _
        9), Array(14, 2)), TrailingMinusNumbers:=True
    Columns("B:B").Replace What:="OK", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula
    Tablo = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row).Value2
    y = LBound(Tablo): z = UBound(Tablo)
    For x = y To z
        If (InStr(1, Tablo(x, 1), ",") > 0 Or InStr(1, Tablo(x, 1), ".") > 0 Or IsNumeric(Tablo(x, 1))) And (IsNumeric(Left(Tablo(x, 1), 1)) Or Left(Tablo(x, 1), 1) = "." Or Left(Tablo(x, 1), 1) = ",") Then
            Tablo2 = Tablo2 & Tablo(x, 1)
        End If
        If Not Tablo2 = "" Then If Left(Tablo(x, 1), 1) = "P" And IsNumeric(Mid(Tablo(x, 1), 2, 1)) Then Tablo2 = Tablo2 & ","
    Next x
    Columns("A:B").ClearContents
    Columns("A:C").NumberFormat = "@"
    Tablo = Split(Tablo2, ",")
    ReDim Tablo3(1 To Application.WorksheetFunction.RoundUp((UBound(Tablo) - LBound(Tablo) + 1) / 3, 0), 1 To 3)
    i = LBound(Tablo)
    For x = LBound(Tablo) To UBound(Tablo) Step 3
        i = i + 1
        Tablo3(i, 1) = Tablo(x)
        Tablo3(i, 2) = Tablo(x + 1)
        Tablo3(i, 3) = Tablo(x + 2)
    Next x
    Range("A1:C" & UBound(Tablo3, 1)).Value2 = Tablo3
End Sub
Merci bcp Yeahou!!!
je relis ça en détails .
Bien Cordialement ,
 

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
re,

Code modifié, un peu plus rapide

Cordialement, @+
VB:
Sub Import_donnees()
    Dim Tablo, Tablo2$, Tablo3$(), Val_Tab$, x&, y&, z&, i&, Nom_Fichier$
    With Application.FileDialog(msoFileDialogFilePicker)
        .ButtonName = "Lire"
        .AllowMultiSelect = False
        .Title = "Choisissez le fichier à importer"
        .Filters.Clear
        .Filters.Add "Extraction données", "*.txt; *.txt", 1
        .Show
        If .SelectedItems.Count > 0 Then
            Nom_Fichier = .SelectedItems(1)
        Else
            MsgBox "Aucun fichier sélectionné", vbOKOnly + vbInformation, "Information"
            Exit Sub
        End If
    End With
    Workbooks.OpenText Filename:=Nom_Fichier, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), Array(4, _
        9), Array(14, 2)), TrailingMinusNumbers:=True
    Columns("B:B").Replace What:="OK", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula
    Tablo = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row).Value2
    y = LBound(Tablo): z = UBound(Tablo)
    For x = y To z
        Val_Tab = Left(Tablo(x, 1), 1)
        If InStr(1, Tablo(x, 1), ".") > 0 Or InStr(1, Tablo(x, 1), ",") > 0 Then
            If IsNumeric(Val_Tab) Or Val_Tab = "." Or Val_Tab = "," Then
                Tablo2 = Tablo2 & Tablo(x, 1)
            End If
        End If
        If Not Tablo2 = "" Then
            If Val_Tab = "P" Then
                If IsNumeric(Mid(Tablo(x, 1), 2, 1)) Then Tablo2 = Tablo2 & ","
            End If
        End If
    Next x
    Columns("A:B").ClearContents
    Columns("A:C").NumberFormat = "@"
    Tablo = Split(Tablo2, ",")
    ReDim Tablo3(1 To Application.WorksheetFunction.RoundUp((UBound(Tablo) - LBound(Tablo) + 1) / 3, 0), 1 To 3)
    i = LBound(Tablo)
    For x = LBound(Tablo) To UBound(Tablo) Step 3
        i = i + 1
        Tablo3(i, 1) = Tablo(x)
        Tablo3(i, 2) = Tablo(x + 1)
        Tablo3(i, 3) = Tablo(x + 2)
    Next x
    Range("A1:C" & UBound(Tablo3, 1)).Value2 = Tablo3
End Sub
 

Discussions similaires

Réponses
10
Affichages
584
Réponses
3
Affichages
161

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh