Number Search / return corresponding number strings

[dwrowe001]

Yes, I am in need of and respectfully request assistance with my project... ..
I need help developing a VBA macro which will search a huge list of numbers for a specified number, then return a specified set of numbers and continue down the list searching for the specified number until it reaches the bottom. The number array I need to search 9761 rows, C4 to F9763....

Each time the specified number is found the macro should return the numbers to the right of it and also the two rows of numbers Below it.

So for example:
if I'm searching for the number 038, which I put in cell J2. I then would like to click a button (in I1 in my example), the search will start at the top of the list. The first instance of 038 (in cell B4)is in the first line.. so return 83, 10, and 05, and the two lines below, B5:E6. Duplicates should not be returned, but they shoiuld be noted as to how many have been found as indicated by numbers in columns H, J, L and N. So the 10 in Cell E5 is the second ten recorded, so the 2nd ten shouldn't be included in the list of numbers returned. just increment J4 to 2.

The second 038 found is on the 3rd line (Cell C6), so record 46, 62, 41, 32, 90 and 08. the numbers 23, 36 and 64 were previously recorded when the first 38 was found. So their Qty numbers in H5, N5 and H6 should be incremented by 1 each.

For the third 038 found (Cell E14) since there are no numbers to the right of it on the same line, just return the 2 rows below it. number 46 was previously found, and 75 was found in line in same group, so only return 1, and increment its Qty count in J11.

The 4th 038 found in this example was found on B17, return numbers 45 and 56, all the other numbers found were previously found, so increment their Qty numbers, don't list them.

The Colors I used in the example aren't needed.. I just did that for clarity.

I this makes sense and isn't asking to much?... I don't know if regular XCEL formulas can do what I would like to do. Thank you in advance for taking the time to review my request and helping.
Thank you
Dave R.

 

[DanteAmor]

Try the following macro.

ATTENTION!!!​

You should consider the following:

1. Your image does not match the columns of your narrative. For example:​

Duplicates should not be returned, but they shoiuld be noted as to how many have been found as indicated by numbers in columns H, J, L and N.​

​

2. So, the macro considers the data as it is in your image.​

​

3. The macro considers that columns C to F are texts. This is important, they must all be texts, I say this, because in your examples you have data like "00", "01", "05". So I assume they are texts.​

​

4. The macro considers that the data you put in cell J2 is text. In your example you have "038" but that number does not exist in the data range, the number that exists is "38", so you must be very careful with the data you write in cell J2. For example, you must write "05" and not just 5, neither "005", you must be very textual. The data must match exactly.​

​

5. In your example the number 64 must have on the counter 4 times.​

6. The results in columns J through Q, starting in cell J4.​

Please, you should review the previous points, I am trying in the macro to minimize the problem of numbers vs texts, but it would help if you verify your data in the sheet.

Sub Number_Search()
  Dim dic As Object
  Dim a As Variant, b As Variant
  Dim i&, j&, n&, jj&, ii&, y&, k&, m&, nRow&, nCol&
  Dim num As String, myNum As String
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("C4:F" & Range("C" & Rows.Count).End(3).Row).Value
  num = Range("J2").Text
  n = WorksheetFunction.CountIf(Range("C:F"), num)
  ReDim b(1 To n * 4, 1 To 8)
  y = -1
 
  Range("J4:Q" & Rows.Count).ClearContents
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      myNum = "" & a(i, j)
      If myNum = num Then
        y = y + 2
        m = j + 1
        k = -1
        For ii = i To i + 2
          For jj = m To UBound(a, 2)
            myNum = "" & a(ii, jj)
            If Not dic.exists(myNum) Then
              k = k + 2
              If k = 9 Then
                k = 1
                y = y + 1
              End If
              dic(myNum) = y & "|" & k
            End If
            nRow = Split(dic(myNum), "|")(0)
            nCol = Split(dic(myNum), "|")(1)
            b(nRow, nCol) = myNum
            b(nRow, nCol + 1) = b(nRow, nCol + 1) + 1
          Next jj
          m = 1
        Next ii
      End If
    Next j
  Next i
 
  Range("J4").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Peter_SSs]

This is my attempt

Sub FindAndCount()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim r As Long, c As Long, fr As Long, fc As Long, x As Long, y As Long, z As Long
  Dim rFound As Range
  Dim FirstAddr As String, s As String
  
  Set d = CreateObject("Scripting.Dictionary")
  x = Range("J2").Value
  y = -1
  z = 0
  With Range("C3", Range("F" & Rows.Count).End(xlUp))
    ReDim a(1 To .Rows.Count, 1 To 8)
    Set rFound = .Find(What:=x, after:=.Cells(1, 1), LookAt:=xlWhole, SearchOrder:=xlByRows)
    If Not rFound Is Nothing Then
      FirstAddr = rFound.Address
      Do
        fr = rFound.Row - .Row + 1
        fc = rFound.Column - .Column + 1
        d("S" & d.Count) = 1
        For r = fr To fr + 2
          For c = 1 To 4
            If r > fr Or c > fc Then
              s = .Cells(r, c).Value
              If s <> CStr(x) Then
                If Not d.exists(s) Then
                  d(s) = 0
                End If
                d(s) = d(s) + 1
              End If
            End If
          Next c
        Next r
        Set rFound = .Find(What:=x, after:=rFound)
      Loop Until rFound.Address = FirstAddr
      For Each Ky In d.Keys
        If Left(Ky, 1) = "S" Then
          y = y + 2
          z = -1
        Else
          z = z + 2
          If z > 7 Then
            y = y + 1
            z = 1
          End If
          a(y, z) = Ky
          a(y, z + 1) = d(Ky)
        End If
      Next Ky
    End If
    With .Offset(1, 7).Resize(, 8)
      .Value = a
      For c = 2 To .Columns.Count Step 2
        .Columns(c).Font.Size = 7
      Next c
    End With
  End With
End Sub

Before:

dwrowe001.xlsm
	C	D	E	F	G	H	I	J	K
1
2								038
3
4	38	83	10	05
5	22	23	01	10
6	83	38	36	64
7	46	62	64	41
8	32	23	90	08
9	37	74	11	15
10	73	31	53	33
11	19	90	53	36
12	90	02	00	01
13	28	10	02	24
14	66	68	03	38
15	87	75	24	42
16	34	46	37	75
17	38	22	90	05
18	41	62	37	10
19	64	08	45	56
20
Sheet1

After:

 

[DanteAmor]

Hi Peter, in the op's image the number 38 appears at the output in the first block.

 

[Peter_SSs]

Hi Peter, in the op's image the number 38 appears at the output in the first block.

Quite correct, I had not checked my results carefully enough. Thanks for pointing it out Dante.
I think eliminating these two lines of my code as shown below is all that is required.

I agree with you about the count for 64 being 4.

Sub FindAndCount_v2()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim r As Long, c As Long, fr As Long, fc As Long, x As Long, y As Long, z As Long
  Dim rFound As Range
  Dim FirstAddr As String, s As String
 
  Set d = CreateObject("Scripting.Dictionary")
  x = Range("J2").Value
  y = -1
  z = 0
  With Range("C3", Range("F" & Rows.Count).End(xlUp))
    ReDim a(1 To .Rows.Count, 1 To 8)
    Set rFound = .Find(What:=x, after:=.Cells(1, 1), LookAt:=xlWhole, SearchOrder:=xlByRows)
    If Not rFound Is Nothing Then
      FirstAddr = rFound.Address
      Do
        fr = rFound.Row - .Row + 1
        fc = rFound.Column - .Column + 1
        d("S" & d.Count) = 1
        For r = fr To fr + 2
          For c = 1 To 4
            If r > fr Or c > fc Then
              s = .Cells(r, c).Value
              If s <> CStr(x) Then
                If Not d.exists(s) Then
                  d(s) = 0
                End If
                d(s) = d(s) + 1
              End If
            End If
          Next c
        Next r
        Set rFound = .Find(What:=x, after:=rFound)
      Loop Until rFound.Address = FirstAddr
      For Each Ky In d.Keys
        If Left(Ky, 1) = "S" Then
          y = y + 2
          z = -1
        Else
          z = z + 2
          If z > 7 Then
            y = y + 1
            z = 1
          End If
          a(y, z) = Ky
          a(y, z + 1) = d(Ky)
        End If
      Next Ky
    End If
    With .Offset(1, 7).Resize(, 8)
      .Value = a
      For c = 2 To .Columns.Count Step 2
        .Columns(c).Font.Size = 7
      Next c
    End With
  End With
End Sub

\

 

[dwrowe001]

Quite correct, I had not checked my results carefully enough. Thanks for pointing it out Dante.
I think eliminating these two lines of my code as shown below is all that is required.

I agree with you about the count for 64 being 4.

Sub FindAndCount_v2()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim r As Long, c As Long, fr As Long, fc As Long, x As Long, y As Long, z As Long
  Dim rFound As Range
  Dim FirstAddr As String, s As String
 
  Set d = CreateObject("Scripting.Dictionary")
  x = Range("J2").Value
  y = -1
  z = 0
  With Range("C3", Range("F" & Rows.Count).End(xlUp))
    ReDim a(1 To .Rows.Count, 1 To 8)
    Set rFound = .Find(What:=x, after:=.Cells(1, 1), LookAt:=xlWhole, SearchOrder:=xlByRows)
    If Not rFound Is Nothing Then
      FirstAddr = rFound.Address
      Do
        fr = rFound.Row - .Row + 1
        fc = rFound.Column - .Column + 1
        d("S" & d.Count) = 1
        For r = fr To fr + 2
          For c = 1 To 4
            If r > fr Or c > fc Then
              s = .Cells(r, c).Value
              If s <> CStr(x) Then
                If Not d.exists(s) Then
                  d(s) = 0
                End If
                d(s) = d(s) + 1
              End If
            End If
          Next c
        Next r
        Set rFound = .Find(What:=x, after:=rFound)
      Loop Until rFound.Address = FirstAddr
      For Each Ky In d.Keys
        If Left(Ky, 1) = "S" Then
          y = y + 2
          z = -1
        Else
          z = z + 2
          If z > 7 Then
            y = y + 1
            z = 1
          End If
          a(y, z) = Ky
          a(y, z + 1) = d(Ky)
        End If
      Next Ky
    End If
    With .Offset(1, 7).Resize(, 8)
      .Value = a
      For c = 2 To .Columns.Count Step 2
        .Columns(c).Font.Size = 7
      Next c
    End With
  End With
End Sub

View attachment 94744\

 

[dwrowe001]

Peter, Dante
just looking at the code, I know there is no way I could have come up with this on my own. Thank you both for your help with this.. I am greatly appreciative. I haven't tried it yet as I am not 100% sure how... can you please step me through where I need to paste the code??

The table I am searching on is located at A4 down to F9763. And I manually add new lines at the bottom each day. I neglected to mention this in my original post my apologies on this. Does the code take this into consideration??

Please let me know how to implement this code into my worksheet.

Dave

 

[DanteAmor]

The number array I need to search 9761 rows, C4 to F9763....

The table I am searching on is located at A4 down to F9763.

The macro is prepared to take the data from cell C4 to F and up to the last row with data, the last row is not fixed, if you increase 2 or 10 rows, the macro automatically identifies the last row with data. Don't worry about that.

The interesting thing about your data is that the macro does not need to read the data from column A and B, we assume that the data is already correct from column C to F, so the macro takes the data from C4 to F and always the last one row that exists at the time you run the macro.

--------------------------------

HOW TO INSTALL MACROs​

If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy the above code into the code window that just opened up.

Example:

That's it.... you are done.

To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (Number_Search) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Let me know if you have any questions.

 

[Peter_SSs]

And I manually add new lines at the bottom each day. ... Does the code take this into consideration??

Mine did not since the original description sounded like a one-off job, but the code below does. Just run it (steps have been provided by Dante) each time after you have added the new lines.

Sub FindAndCount_v3()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim r As Long, c As Long, fr As Long, fc As Long, x As Long, y As Long, z As Long
  Dim rFound As Range
  Dim FirstAddr As String, s As String

  Set d = CreateObject("Scripting.Dictionary")
  x = Range("J2").Value
  y = -1
  z = 0
  Range("J1", Range("J" & Rows.Count).End(xlUp)).Resize(, 8).Offset(3).Clear
  With Range("C3", Range("F" & Rows.Count).End(xlUp))
    ReDim a(1 To .Rows.Count, 1 To 8)
    Set rFound = .Find(What:=x, after:=.Cells(1, 1), LookAt:=xlWhole, SearchOrder:=xlByRows)
    If Not rFound Is Nothing Then
      FirstAddr = rFound.Address
      Do
        fr = rFound.Row - .Row + 1
        fc = rFound.Column - .Column + 1
        d("S" & d.Count) = 1
        For r = fr To fr + 2
          For c = 1 To 4
            If r > fr Or c > fc Then
              s = .Cells(r, c).Value
              If Not d.exists(s) Then d(s) = 0
              d(s) = d(s) + 1
            End If
          Next c
        Next r
        Set rFound = .Find(What:=x, after:=rFound)
      Loop Until rFound.Address = FirstAddr
      For Each Ky In d.Keys
        If Left(Ky, 1) = "S" Then
          y = y + 2
          z = -1
        Else
          z = z + 2
          If z > 7 Then
            y = y + 1
            z = 1
          End If
          a(y, z) = Ky
          a(y, z + 1) = d(Ky)
        End If
      Next Ky
    End If
    With .Offset(1, 7).Resize(, 8)
      .Value = a
      For c = 2 To .Columns.Count Step 2
        .Columns(c).Font.Size = 7
      Next c
    End With
  End With
End Sub

 

[dwrowe001]

Peter, Dante,
Well, I followed Dante's instructions on where to put the code and then how t run it.. When I run Dante's versions I get an error, when I click the Debug button it takes me to the code showing me highlighted line which I uploaded. When I try running Peter's code, nothing happens at all, not error... nothing. Bummer.

The sheet, before I try running the code looks like Pic3 (uploaded). I uploaded this pic just for your reference.. the numbers are from cell C4 down to F9763. There's nothing else on the sheet.

Dave