Extract data from specific strings column

cristu · Jun 28th 2022

Hello,

I have a large worksheet that contains detailed data on various column fields, an I only want to extract rows from a specific range strings and concatenate date to another sheet, separated by commas.

Strings: Person and DECDENT (extract text between)

I attach an example with 'extract.xlsx' sheet4 and the 'result' sheet as I want to look

Is there a way to do this via VB script/macro ?

Thanks

**KjBox** · Jun 28th 2022

When the code runs do you want it to replace any data on the "result" sheet (apart from the header row) or to add new data to any existing data?

cristu · Jun 29th 2022

Hi KjBox

Sorry for delayed response

On the result sheet I want to replace any data not to add, It's one time run.

Thanks

**KjBox** · Jun 29th 2022

Try this. It will add a new sheet to your workbook, name the new sheet "Extracted Data" and place the extracted data there.

Code

Sub Extract()
    Dim x, y, i&, ii&, ws As Worksheet
    
    x = Sheets("Sheet4").UsedRange.Columns(1)   'Change sheet name to suit
    ReDim y(1 To UBound(x, 1), 1 To 4)
    y(1, 1) = "Person": y(1, 2) = "Address": y(1, 3) = "Represent": y(1, 4) = "Address"
    ii = 1
    For i = 1 To UBound(x, 1)
        If x(i, 1) Like "*Person:*" Then
            ii = ii + 1
            y(ii, 1) = Replace(x(i, 1), "Person: ", "")
            Do Until x(i, 1) Like "*DECDENT*"
                If Len(x(i, 1)) Then
                    If x(i, 1) Like "*Adresa:*" Then
                        y(ii, 2) = Replace(x(i, 1), "Adresa: ", "")
                        i = i + 1
                        Do Until x(i, 1) = vbNullString
                            If Right(y(ii, 2), 1) = "," Then
                                y(ii, 2) = y(ii, 2) & " " & x(i, 1)
                            Else
                                y(ii, 2) = y(ii, 2) & ", " & x(i, 1)
                            End If
                            i = i + 1
                            If i >= UBound(x, 1) Then Exit Do
                        Loop
                    ElseIf x(i, 1) Like "*Represent*" Then
                        y(ii, 3) = Replace(x(i, 1), "Represent: ", "")
                    ElseIf x(i, 1) Like "*Address*" Then
                        y(ii, 4) = Replace(x(i, 1), "Address: ", "")
                        i = i + 1
                        Do Until x(i, 1) = vbNullString
                            y(ii, 4) = y(ii, 4) & ", " & x(i, 1)
                            i = i + 1
                            If i >= UBound(x, 1) Then Exit Do
                        Loop
                    End If
                End If
                i = i + 1
                If i >= UBound(x, 1) Then Exit Do
            Loop
        End If
    Next
    Set ws = Sheets.Add(, Sheets(Sheets.Count))
    With ws
        .Name = "Extracted Data"
        .[a1].Resize(UBound(y, 1), 4) = y
        .Columns(1).Resize(, 4).AutoFit
        .Activate
    End With
End Sub

Display More

cristu · Jun 30th 2022

Thank you sir.

**KjBox** · Jun 30th 2022

You're welcome

Extract data from specific strings column

Participate now!

Share

Similar Threads

Help Extracting Data From String

extracting data from strings

How to extract a specific data in a column and parse it in another column with VBA

Command Button to paste data from specific Cells of Specific sheet to specific Cells of Specific sheet

Extract specific ranges from columns and put in another sheet VBA

Extract Specific Text from a Cell