Extraction de données

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

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

A+

19listedesoudure.xlsm (17.02 Ko)

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

klin89

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

A+

11listedesoudure.xlsm (17.59 Ko)

Un petit oubli curulis57,

.Range("B" & iRow).Resize(1, UBound(tSplit1, 1) ).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tSplit1))

klin89

Salut Klin,

joli coup d'oeil!

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+

Bonjour à tous

Un essai à tester.

Bye !

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

re duee

remplace le pattern ci dessous :

.Pattern = "\d+"

par celui-ci

.Pattern = "-?\d+"

klin89

Rechercher des sujets similaires à "extraction donnees"