VBA Script to extract two sets of numbers between text in cell

[johnbrownbaby]

Hello,

Thanks to the elegant solution to the first question posted here, I was able to get a formula based solution. I am finding that if the data is given like this:

I am having a problem keeping up with the formula based approach. How can I do this from VB script viewpoint to collect the data from column A where all the "eFine" and "eFood" numbers are placed in separate columns found in K and L respectively?

I posted a preliminary question on OzGrid found here but I do not know how to delete that question to make this updated question priority.

test1.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1											Test 1	Amp
2											2404852	12827
3											2404892	12855
4											2404860	12914
5											2404589	13015
6
7	Pack: AMPLITUDE_ACCESS
8	eFine: 2404852 eFood: 12827
9
10
11
12
13
14	Pack: AMPLITUDE_ACCESS
15	eFine: 2404892 eFood: 12855
16
17
18
19
20
21	Pack: AMPLITUDE_ACCESS
22	eFine: 2404860 eFood: 12914
23
24
25
26
27
28	Pack: AMPLITUDE_ACCESS
29	eFine: 2404589 eFood: 12015
30
31	***
32	*** DISCONNECT
33	*** time 14:38:02
34	***
35
36
37	[INFO] INFO: DISCONNECTED
38
39
40	Pack: AMPLITUDE_ACCESS
41	eFine: 2404892 eFood: 12855
42
43
44
45
46
47	Pack: AMPLITUDE_ACCESS
48	eFine: 2404860 eFood: 12914
49
50
51
52
53
54	Pack: AMPLITUDE_ACCESS
55	eFine: 2404589 eFood: 12015
56
57	***
58	*** DISCONNECT
59	*** time 14:38:02
60	***
61
62
63	[INFO] INFO: DISCONNECTED
Sheet1

Thanks for your help and time!

 

[DanteAmor]

Try this:

Sub extract_two_sets_of_numbers()
  Dim r As Range, f As Range
  Dim cell As String
  Dim arr As Variant
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set r = Range("A1", Range("A" & Rows.Count).End(3))
  Set f = r.Find("eFine", , xlValues, xlPart, , , False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      arr = Split(f.Value, " ")
      If Not dic.exists(arr(1)) Then
        dic(arr(1)) = Empty
        Range("K" & Rows.Count).End(3)(2).Resize(, 2).Value = Array(arr(1), arr(3))
      End If
      Set f = r.FindNext(f)
    Loop While Not f Is Nothing And f.Address <> cell
  End If
End Sub

 

[johnbrownbaby]

Hello,

Thanks for your code. I tried it but it works partially. It stops filling column K, L when it sees the "***". For the example spreadsheet I posted, I only get 4 entries, I should get 7. How to get all the entries with the "eFine" and "eFood"?

Thanks!

 

[johnbrownbaby]

You code works. I just needed to get rid of the last "If" statement. Thank you!

 

[Rick Rothstein]

Give this macro a try...

Sub ExtractNumbers()
  Dim X As Long, Arr As Variant, Parts As Variant, Result As Variant
  Arr = Filter(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), "eFine:", True, vbTextCompare)
  ReDim Result(LBound(Arr) To UBound(Arr), 1 To 2)
  For X = LBound(Arr) To UBound(Arr)
    Parts = Split(Arr(X))
    Result(X, 1) = Parts(1)
    Result(X, 2) = Parts(3)
  Next
  Range("K2").Resize(UBound(Result), 2) = Result
End Sub

 

[johnbrownbaby]

How to make this code work on multiple Sheets in the workbook?

Thanks!

 

[Rick Rothstein]

Do you mean all the sheets in the workbook or only some of them? If only some of them, what sheets are they (the code needs someway to identify them)?

 

[Rick Rothstein]

Also, who are you directing your question to... Dante or me?

 

[DanteAmor]

For the example spreadsheet I posted, I only get 4 entries, I should get 7.

In your example you only have 4 results, I assumed that you only wanted the unique values. But if you want all, on all sheets, try the following. The results will be on the first sheet.

Sub extract_two_sets_of_numbers2()
  Dim r As Range, f As Range
  Dim cell As String
  Dim arr As Variant
  Dim sh As Worksheet
  
  For Each sh In Sheets
    Set r = sh.Range("A1", sh.Range("A" & Rows.Count).End(3))
    Set f = r.Find("eFine", , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        arr = Split(f.Value, " ")
        Sheets(1).Range("K" & Rows.Count).End(3)(2).Resize(, 2).Value = Array(arr(1), arr(3))
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
End Sub

 

[johnbrownbaby]

Also, who are you directing your question to... Dante or me?

Thanks for your solution and help! Sincerely appreciate your time!