Autres Organiser des données sur VBA

K

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
Bernard_XLD
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...
Trier par date Trier par votes
sylvanu

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
Vote positif 0 Vote négatif
K

KManu

XLDnaute Nouveau
Yeahou à dit:
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, @+
Cliquez pour agrandir...
Yeahou à dit:
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, @+
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
K

KManu

XLDnaute Nouveau
sylvanu à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
K

KManu

XLDnaute Nouveau
Yeahou à dit:
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
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
K

KManu

XLDnaute Nouveau
sylvanu à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
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
Vote positif 0 Vote négatif
K

KManu

XLDnaute Nouveau
Yeahou à dit:
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
Cliquez pour agrandir...
Merci bcp Yeahou!!!
je relis ça en détails .
Bien Cordialement ,
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
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
 
Vote positif 0 Vote négatif
Solution

Discussions similaires

J
  • Résolu(e)
Microsoft 365 [RESOLU] VBA boucle, insertion plusieurs lignes, exécution formules, suppression sur si
Réponses
5
Affichages
430
Phil69970
Phil69970
A
  • Résolu(e)
XL 2019 VBA - Copie données selon 3 critères
Réponses
4
Affichages
265
abouilies
A
S
  • Question
XL 2016 Transposer colonnes sur lignes
2 3
Réponses
32
Affichages
1 K
soumus
S
J
  • Résolu(e)
XL 2021 Problème code VBA
Réponses
10
Affichages
643
Phil69970
Phil69970
H
  • Question
Microsoft 365 Trier des données dans une colonne avec VBA
Réponses
9
Affichages
540
HUMANUM79
H
A
  • Résolu(e)
XL 2016 Copier Coller données avec VBA dernière cellules vide
Réponses
13
Affichages
685
Anto35200
A
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
679
Pac41240
P
S
  • Résolu(e)
XL 2016 copier des données d'une feuille à une autre selon critères et protection de la feuille 1
Réponses
6
Affichages
421
steph_29120
S
Lisette
  • Question
Microsoft 365 VBA : copier / coller d'un onglet à l'autre en fonction d'une valeur
Réponses
8
Affichages
551
Lisette
Lisette
M
  • Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
262
mromain
mromain

Membres actuellement en ligne

19 membres et 224 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 104
Messages
2 116 251
Membres
112 697
dernier inscrit
administratif@ets-delestr