Need assistance copying Cells that just contain certain data

Hello,

In column A of my spreadsheet I have a following data. I'm looking to copy just the cells that contain (DLR A/C: xxxxxxx). To make things more complicated, I just need the VBA macro to copy what follows the DLR A/C: part (what's bolded). It also doesn't help that there's about 6 spaces between each account information. I need the data to be pasted on another tab/workbook without the spaces in between each account information.

Account Number
5435234543
(DLR A/C: 432434432)



Account Number
454543534
(DLR A/C: MPR434432)



Account Number
454543534
(DLR A/C: 87868675)

First time poster and new member. Please let me know if I need to go about this request differently.

Much Appreciated!

Best put together a sample workbook, perhaps even with an 'expected results' sheet too, and attach it here, then we can experiment with a variety of solutions without guessing (wrongly) what's in your workbook.
I suspect there'll be a (longish) formula solution, a macro solution and a Power Query solution.

Quote:

---

Originally Posted by p45cal

Best put together a sample workbook, perhaps even with an 'expected results' sheet too, and attach it here, then we can experiment with a variety of solutions without guessing (wrongly) what's in your workbook.
I suspect there'll be a (longish) formula solution, a macro solution and a Power Query solution.

---

No problem. Attached is an example of what I'm working with. The Shareholders sheet is how the data looks when I receive it. I need to pull the number following the DLR A/C part and have it be copied over to the Final sheet. On Final sheet I have it updated to what it should look like when the macro is done.

Thanks

Try this

Code:

---

Public Sub ExtractAcNumbers()
Dim wsShareholders As Worksheet
Dim wsFinal As Worksheet
Dim lastrow As Long
Dim nextrow As Long
Dim i As Long

    Application.ScreenUpdating = False
   
    Set wsShareholders = Worksheets("Shareholders")
    Set wsFinal = Worksheets("Final")
   
    With wsFinal
   
        nextrow = 1
        With .Cells(nextrow, "A")
       
            .Value = "Dealer Account Number"
            .Font.Bold = True
            .Font.Underline = True
        End With
    End With
   
    With wsShareholders
       
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lastrow
       
            If Left$(.Cells(i, "A").Value, 9) = "(DLR A/C:" Then
           
                nextrow = nextrow + 1
                wsFinal.Cells(nextrow, "A").Value = Mid$(.Cells(i, "A").Value, 10, Len(.Cells(i, "A").Value) - 10)
            End If
        Next i
    End With
   
    Application.ScreenUpdating = True
End Sub

---

This is perfect Bob, much appreciated. Thanks!!!

Of course, I came across an exception in the final results I overlooked and need to account for. Looks like every so often a DLR A/C number isn't given when there's an account number provided. When that happens there should be blank cell in the Final tab. Not sure if that is even possible to do?

I've attached a new example spreadsheet, where there's a case when a DLR A/C number isn't provided (highlighted in yellow). Then on the Final tab am empty cell should be provided.

Thanks in advance

Try this amendment

Code:

---

Public Sub ExtractAcNumbers()
Dim wsShareholders As Worksheet
Dim wsFinal As Worksheet
Dim target As String
Dim lastrow As Long
Dim nextrow As Long
Dim i As Long

    Application.ScreenUpdating = False
   
    Set wsShareholders = Worksheets("Shareholders")
    Set wsFinal = Worksheets("Final")
   
    With wsFinal
   
        .Columns(1).ClearContents
   
        nextrow = 1
        With .Cells(nextrow, "A")
       
            .Value = "Dealer Account Number"
            .Font.Bold = True
            .Font.Underline = True
        End With
    End With
   
    With wsShareholders
       
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 1 To lastrow
       
            If .Cells(i, "A").Value = "Account Number" Then
           
                target = vbNullString
                Do
                   
                    i = i + 1
                    If Left$(.Cells(i, "A").Value, 9) = "(DLR A/C:" Then
                   
                        target = Mid$(.Cells(i, "A").Value, 10, Len(.Cells(i, "A").Value) - 10)
                    End If
                Loop Until .Cells(i, "A").Value = "Account Number" Or i > lastrow
           
                nextrow = nextrow + 1
                wsFinal.Cells(nextrow, "A").Value = target
                i = i - 1
            End If
        Next i
    End With
   
    Application.ScreenUpdating = True
End Sub

---

Perfect, thanks!