Extraction de données

Y compris Power BI, Power Query et toute autre question en lien avec Excel
d
duee
Nouveau venu
Nouveau venu
Messages : 6
Inscrit le : 25 octobre 2018
Version d'Excel : 2010en

Message par duee » 29 octobre 2018, 19:55

Bonjour je suis sur un sujet qui me pose problème
Sur des listes de soudure que je relève sur un robot et que je voudrais extraire des informations dans d'autres cellules pour créer une base de données sous Excel
voir fichier joint
Merci
listedesoudure.xlsx
(9.86 Kio) Téléchargé 15 fois
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'711
Appréciations reçues : 217
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 29 octobre 2018, 20:48

Salut duee,

premier jet, vite fait... Je peaufine dans la soirée.
Un double-clic en 'Extract' démarre la macro. Résultat en 'BDD'.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract(), tSplit1, tSplit2
'
tData = Range("A1").Resize(UsedRange.Rows.Count, 1).Value
With Worksheets("BDD")
    For x = 1 To UBound(tData, 1)
        If tData(x, 1) <> "" Then
            iRow = IIf(.Cells(1, 1) = "", 1, .Range("A" & Rows.Count).End(xlUp).Row + 1)
            .Cells(iRow, 1) = Split(Split(tData(x, 1), " =")(0), " ")(1)
            tSplit1 = Split(Split(tData(x, 1), "= (")(1), ")")(0)
            tSplit2 = Split(tSplit1, ",")
            .Range("B" & iRow).Resize(1, UBound(tSplit2, 1)).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tSplit2))
        End If
    Next
End With
'
End Sub
8-)
A+
listedesoudure.xlsm
(17.02 Kio) Téléchargé 19 fois
Avatar du membre
Klin89
Membre dévoué
Membre dévoué
Messages : 596
Appréciations reçues : 21
Inscrit le : 28 mai 2011
Version d'Excel : 2003 FR

Message par Klin89 » 29 octobre 2018, 22:02

Bonsoir à tous, :)

Un essai :
Option Explicit
Sub test()
Dim x, y(), i As Long, j As Long
    With Sheets(1)
        With .Range("A4", .Cells(.Rows.Count, 1).End(xlUp))
            x = .Value
            ReDim y(1 To UBound(x, 1), 1 To 23)
            With CreateObject("VBScript.RegExp")
                .Global = True: .Pattern = "\d+"
                For i = 1 To UBound(x, 1)
                    For j = 0 To .Execute(x(i, 1)).Count - 1
                        y(i, j + 1) = .Execute(x(i, 1))(j)
                    Next
                Next
            End With
            .Offset(, 2).Resize(UBound(y, 1), UBound(y, 2)).Value = y
        End With
    End With
End Sub
Il faut changer le pattern, les nombres négatifs n'apparaissent pas :oops:

klin89
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'711
Appréciations reçues : 217
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 29 octobre 2018, 22:17

Salut tout le monde,

petites corrections... trop vite, c'est trop vite...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tSplit1
'
Cancel = True
Application.ScreenUpdating = False
'
tData = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
With Worksheets("BDD")
    iRow = IIf(.Cells(1, 1) = "", 0, .Range("A" & Rows.Count).End(xlUp).Row)
    For x = 1 To UBound(tData, 1)
        If tData(x, 1) <> "" Then
            iRow = iRow + 1
            .Cells(iRow, 1) = Split(Split(tData(x, 1), " =")(0), " ")(1)
            tSplit1 = Split(Split(Split(tData(x, 1), "= (")(1), ")")(0), ",")
            .Range("B" & iRow).Resize(1, UBound(tSplit1, 1) + 1).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tSplit1))
        End If
    Next
End With
'
Application.ScreenUpdating = True
'
End Sub
:btres:

8-)
A+
listedesoudure.xlsm
(17.59 Kio) Téléchargé 11 fois
Modifié en dernier par curulis57 le 30 octobre 2018, 01:05, modifié 2 fois.
Avatar du membre
Klin89
Membre dévoué
Membre dévoué
Messages : 596
Appréciations reçues : 21
Inscrit le : 28 mai 2011
Version d'Excel : 2003 FR

Message par Klin89 » 29 octobre 2018, 22:38

Un petit oubli curulis57, :wink:
.Range("B" & iRow).Resize(1, UBound(tSplit1, 1) + 1).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tSplit1))
klin89
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'711
Appréciations reçues : 217
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 29 octobre 2018, 23:36

Salut Klin,

joli coup d'oeil! :clap:
Trop sûr de mon coup, je n'avais pas regardé le bout des lignes de résultats... hors écran!
Corrigé dans le post précédent...

Merci.
:)
A+
g
gmb
Fanatique d'Excel
Fanatique d'Excel
Messages : 12'684
Appréciations reçues : 343
Inscrit le : 4 avril 2013
Version d'Excel : 2016

Message par gmb » 30 octobre 2018, 00:10

Bonjour à tous

Un essai à tester.
Bye !
listedesoudure v1.xlsm
(19.26 Kio) Téléchargé 15 fois
d
duee
Nouveau venu
Nouveau venu
Messages : 6
Inscrit le : 25 octobre 2018
Version d'Excel : 2010en

Message par duee » 30 octobre 2018, 20:51

je vous remercie beaucoup les amis pour les programmes de mon sujet ,je suis très content que vous avez résolus mon problème
sa fonction très bien
Merci et bonne soirée a tous
Avatar du membre
Klin89
Membre dévoué
Membre dévoué
Messages : 596
Appréciations reçues : 21
Inscrit le : 28 mai 2011
Version d'Excel : 2003 FR

Message par Klin89 » 31 octobre 2018, 22:23

re duee :)

remplace le pattern ci dessous :
.Pattern = "\d+"
par celui-ci
.Pattern = "-?\d+"
klin89
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message
  • Extraction de données
    par Delgusto » 28 février 2019, 17:00 » dans Excel - VBA
    25 Réponses
    388 Vues
    Dernier message par Delgusto
    3 mars 2019, 15:57
  • Extraction de données
    par balby64 » 26 avril 2017, 22:53 » dans Excel - VBA
    3 Réponses
    128 Vues
    Dernier message par i20100
    27 avril 2017, 00:41
  • Extraction de données
    par Vitya » 22 mai 2016, 00:15 » dans Excel - VBA
    4 Réponses
    132 Vues
    Dernier message par Vitya
    25 mai 2016, 09:56
  • Extraction de données
    par ACCRO » 2 juillet 2019, 10:23 » dans Excel - VBA
    14 Réponses
    151 Vues
    Dernier message par Steelson
    3 juillet 2019, 18:43
  • extraction de données
    par kholkhol » 20 juillet 2014, 20:21 » dans Excel - VBA
    8 Réponses
    255 Vues
    Dernier message par Banzai64
    21 juillet 2014, 11:46
  • Extraction de données
    par fredolilo » 30 décembre 2016, 13:06 » dans Excel - VBA
    4 Réponses
    193 Vues
    Dernier message par fredolilo
    2 janvier 2017, 11:02