Need assistance copying Cells that just contain certain data

[twmills]

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!

[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.

[twmills]

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

[Bob Phillips]

Try this


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

[twmills]

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

[twmills]

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

[Bob Phillips]

Try this amendment


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

[twmills]

Perfect, thanks!