VB Code to pull product ID and Qty Sold from table

[rizmomin]

Hello:

Please refer to attached file.
I am using below code successfully to pull the names from column A by entering part of text in cell E1.

Once i enter then it will populate the FULL NAME of the item in column G.
I need to modify this code so that it can pull corresponding ID# and Qty Sold from Coulmn B and C

Let me know if you have any questions.
Thanks.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then GoTo 10 'Exit Sub
    
    If Intersect(Target, Range("E1")) Is Nothing Then GoTo 10 'Then Exit Sub
    
    If Target.Cells.Count > 1 Then GoTo 10 'Then Exit Sub
    
    Call SearchT(UCase(Trim(Target.Value)) & "*")
10
    
    
End Sub

Option Explicit
'First, mark: Tools => References: "Microsoft Scripting Runtime"
Sub SearchT(whaaat_maaan$)
    Dim r&, c2h5oh$, elem
    Dim dict As New Scripting.Dictionary
    
    If Range("E1") = "" Then Exit Sub
    
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("Select-Item")
        r = .Cells(.Rows.Count, "G").End(xlUp).Row
       ' .Range("F1:F" & r).ClearContents
        r = 2
        Do Until Trim(.Cells(r, 1).Value) = ""
            c2h5oh = Trim(.Cells(r, 1).Value)
            If UCase(c2h5oh) Like whaaat_maaan Then
                If Not dict.Exists(c2h5oh) Then dict(c2h5oh) = c2h5oh
            End If
            r = r + 1
        Loop
        
        'Stop
        
        For Each elem In dict.Keys
            .Range("G" & .Rows.Count).End(xlUp).Offset(1, 0).Value = elem
        Next
        r = .Cells(.Rows.Count, "G").End(xlUp).Row
        '.Range("F1").Value = "C2H5OH"
        .Range("G1").Value = "List"
        With .Range("G1:G" & r)
            .Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes
            .EntireColumn.AutoFit
        End With
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
   ' CopyR = Range("G2:G" & Range("G1").Value)
    
    
    
    
End Sub

Riz

[karedog]

Maybe :

Code on Sheet1 :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$E$1" Then SearchT
End Sub

Code on Module1:

Option Explicit
Option Private Module
Sub SearchT()
  Dim a, e As Long, i As Long, p As Long, strSearch As String, z As New Collection
  With Sheets("Select-Item")
    strSearch = .Range("E1").Value
    a = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(a, 1)
        If InStr(1, a(i, 1), strSearch, vbTextCompare) Then
           On Error Resume Next
              z.Add Key:=CStr(a(i, 1)), Item:=Empty
              e = Err.Number
           On Error GoTo 0
           If e = 0 Then
              p = p + 1
              a(p, 1) = a(i, 1)
              a(p, 2) = a(i, 2)
              a(p, 3) = a(i, 3)
           End If
        End If
    Next i
    Application.ScreenUpdating = False
    .Range("G2:I" & Application.Max(2, .Cells(.Rows.Count, "G").End(xlUp).Row)).ClearContents
    If p Then
       With .Range("G2").Resize(p, UBound(a, 2))
         .Value = a
         .Sort key1:=.Columns(1), order1:=xlAscending, header:=xlNo
         .EntireColumn.AutoFit
       End With
    End If
    Application.ScreenUpdating = True
  End With
End Sub

[rizmomin]

Hello KareDog:

Super, works ...need small change
Have a look at attached file.
I entered "BACAR" and it picked up all entries with text "BACAR".
Now i will go thru list in column G and will delete some.
As i delete, i need LIST, ID and Qty to refresh (Basically shift data UP as i delete.

I hope this is clear.
Please let me know if you have any questions.
Thanks.

Riz

[karedog]

Hi Riz,

Before we continue, we must make some changes to the data first :

1. At current state, your Table (ListObject) only occupied columns A:B, this Table must be enlarged so all data (columns A:C) is inside this Table boundary. For example, if you select A10:C10, then right click mouse button and choose "Delete", all options is Greyed Out, this will not happened if the Table has been enlarged to A:C. To enlarge (resize) the Table, simply go to the most right bottom of the table, and click n drag the corner to the right.

2. You must change the formula on column B to value, for example (assumming you have done the step 1 above), you select A10:C10, right click -> Delete -> Row, then starting from this row downward, all the cell's value become #REF!
So, you need to change the column B formula to value, simply select column B -> Copy (Ctrl C) -> Paste Special -> Values

In the attached file of this post, I have done these for you, and my macro below will assume you have done the 2 requirements above.

This code is to put on a new module (Module2) :

Option Explicit
Sub RemoveT()
  Dim rng As Range, a, i As Long, strSearch As String

  If ActiveSheet.Name <> "Select-Item" Then Exit Sub
  If ActiveCell.Column <> Columns("G").Column Then Exit Sub
  strSearch = Trim$(ActiveCell.Value)
  If Len(strSearch) = 0 Then Exit Sub

  With Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    a = .Value
    For i = 1 To UBound(a, 1)
        If a(i, 1) = strSearch Then If Not rng Is Nothing Then Set rng = Union(rng, .Rows(i)) Else Set rng = .Rows(i)
    Next i
  End With
  If Not rng Is Nothing Then
     Application.ScreenUpdating = False
       rng.Delete xlShiftUp
       ActiveCell.Resize(, 3).Delete xlShiftUp
     Application.ScreenUpdating = True
  End If
End Sub

To run the macro, select an item first (click on a cell) on column G, then run the macro.

[rizmomin]

Hello Karedog:

I think there is small misunderstanding.
When item is selected in column G to be deleted, it only needs deleted in COlumn G and NOT TO BE Affected in column A.
Basically my purpose is to create Custom list from Column G.
Example : Type in BACARDI in cell E1.
This will create list with all text containing "BACARDI".
Now i need the modify list form column G by deleting some unwanted.
So NOTHING HAS TO CHANGE IN COLUMN A THRU C, Just delete entry in COLUMN G:I

Pls help modify the code just to do that.
I hope this is clear and sorry for any misunderstanding.

Thanks a lot

Riz

[karedog]

Riz, then change the code to this :

Option Explicit
Sub RemoveT()
  Dim rng As Range, a, i As Long, strSearch As String

  If ActiveSheet.Name <> "Select-Item" Then Exit Sub
  If ActiveCell.Column <> Columns("G").Column Then Exit Sub
  Application.ScreenUpdating = False
     ActiveCell.Resize(, 3).Delete xlShiftUp
  Application.ScreenUpdating = True
End Sub

To use it, select a cell in column G, and run the macro.
Or, to simplify the process, you can add a Command Button to sheet, and assign the macro to this button, as in my attached file.

[rizmomin]

Hello Karedog:

Works great, would appreciate if i can request one more request.
As we type in new TEXT you are clearing the old one out and putting in TEXT Item.
I DO NOT WANT TO CLEAR OUT THE DATA IN G:I, when i type new text in cell E1 then it needs to go to 1st available cell in column G and sort Alphabettically.

I will have seperate CLEAR Button to clear out all data from G:I.

Thanks a lot

Riz

[karedog]

Replace Sub SearchT() on post #2 with this one :

Option Explicit
Option Private Module
Sub SearchT()
  Dim a, e As Long, i As Long, p As Long, strSearch As String, z As New Collection
  With Sheets("Select-Item")
    strSearch = .Range("E1").Value
    a = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    For i = 1 To UBound(a, 1)
        If InStr(1, a(i, 1), strSearch, vbTextCompare) Then
           On Error Resume Next
              z.Add Key:=CStr(a(i, 1)), Item:=Empty
              e = Err.Number
           On Error GoTo 0
           If e = 0 Then
              p = p + 1
              a(p, 1) = a(i, 1)
              a(p, 2) = a(i, 2)
              a(p, 3) = a(i, 3)
           End If
        End If
    Next i
    Application.ScreenUpdating = False
    If p Then
       With .Cells(.Rows.Count, "G").End(xlUp).Offset(1).Resize(p, UBound(a, 2))
         .Value = a
         .EntireColumn.Sort key1:=.Columns(1), order1:=xlAscending, header:=xlYes
         .EntireColumn.AutoFit
       End With
    End If
    Application.ScreenUpdating = True
  End With
End Sub

[rizmomin]

Hello karedog:

Yes it works.
In Delete, i am selecting say 4 items in Column G but its only deleting one item.
Can we make it per selection


Thanks

Riz

[rizmomin]

Hello:

Probably need to modify below to delete total selection instead of ActiveCell.

Application.ScreenUpdating = False
     ActiveCell.Resize(, 3).Delete xlShiftUp
  Application.ScreenUpdating = True

[rizmomin]

Hello Karedog:

Yes I got it, i changed above from Activecell to Selection.

Thanks a lot for great Help..........

Riz

[karedog]

Hi Riz, glad you can fix it by yourself.
Thanks for marking the thread as solved and rep.points.

Regards