Assiging certain text in a cell column headings to return Hi! I need some help w

Question

Assiging certain text in a cell column headings to return

Hi! I need some help with a macro. I have a worksheet which I copy new data to daily and I need it be able to put a button to search for specific data in column A . When this search is done it will bring up all the items for that number I searched for. Each number will have different information that will pull in column C. I then need it to based on the data in column c pull on certain row headings and there data. Then it needs to pull into another sheet I can show better than I can explain. I have a button that brings a box up and asks for spool# and I enter the number from list that I want data for and it will copy that number and all its corresponding rows to the next sheet. (see attached Macro).

Current Macro: to pull just spool number and its corresponding rows..

Sub SearchForString()

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer
    Dim LSearchValue As String
   
    On Error GoTo Err_Execute
   
    LSearchValue = InputBox("Please enter a value to search for.", "Enter value")
         
    'Start search in row 4
    LSearchRow = 4
   
    'Start copying data to row 16 in Sheet2 (row counter variable)
    LCopyToRow = 16
   
    While Len(Range("A" & CStr(LSearchRow)).Value) > 0
       
        'If value in column A = LSearchValue,copy entire row to Sheet2
        If Range("A" & CStr(LSearchRow)).Value = LSearchValue Then
           
            'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy
           
            'Paste row into Sheet2 in next row
            Sheets("Sheet2").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
           
            'Move counter to next row
            LCopyToRow = LCopyToRow + 1
           
            'Go back to Sheet1 to continue searching
            Sheets("Sheet1").Select
           
        End If
       
        LSearchRow = LSearchRow + 1
       
    Wend
   
    'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select
   
    MsgBox "All matching data has been copied."
   
    Exit Sub
   
Err_Execute:
    MsgBox "An error occurred."
   
End Sub

Result I need to have copied into next worksheet When the search box comes up I want to be able to enter the spool# and based on the type of material it returns for that spool in Column C (this will vary from spool to spool) I need it pull the corresponding columns containing the elements for that particular metal (Elements will vary also according to material type) Example: Stainless Steel= Readings for Column Mo,Cu & Fe... Chrome=Readings for Column W,Ni & Cr.

Spool# Readings Material Mo Nb W Cu Ni Fe Cr 12345 1 Carbon Steel 1.2 1.2 1.2 1.2 1.2 1.2 1.2 12345 2 Carbon Steel 2.2 2.2 2.2 2.2 2.2 2.2 2.2 12345 3 Stainless Steel 3.3 3.3 3.3 3.3 3.3 3.3 3.3 678910 4 Stainless Steel 4.4 4.4 4.4 4.4 4.4 4.4 4.4 678910 5 Stainless Steel 5.5 5.5 5.5 5.5 5.5 5.5 5.5 678910 6 Stainless Steel 6.6 6.6 6.6 6.6 6.6 6.6 6.6 111213 1 Chrome 7.8 7.8 7.8 7.8 7.8 7.8 7.8 111213 2 Chrome 9.10 9.10 9.10 9.10 9.10 9.10 9.10

Explanation / Answer

Here is some code that will produce the results you want from the data you've posted. It should be obvious where you need to make changes to adapt to your "real" data, but post back with any problems:

Option Explicit
Option Base 1
Sub Spool()
    Dim lSpool As Long 'Maybe as string depending on real data
    Dim sHeaders() As String
    Dim vSrc As Variant 'Source Data
    Dim vRes() As Variant 'Results array
    Dim arrStainless(3) As Long
    Dim arrChrome(3) As Long
    Dim arrCarbonSteel(3) As Long
    Dim arrElements() As Variant
    Dim I As Long, J As Long, K As Long
    Dim lRows As Long, lCols As Long
    Dim sMaterial As String
    Dim arrMaterials() As Long
    Dim wsSrc As Worksheet, wsRes As Worksheet

Set wsSrc = Worksheets("Sheet1") '<--Alter as needed
Set wsRes = Worksheets("Sheet2") '<--Alter as needed
'Get source data
'May need to alter selection method depending on how your real worksheet is set up
With wsSrc
    vSrc = .Range("a1").CurrentRegion
End With

'Get columns for the different materials elements
'Stainless = Mo, Cu, Fe
arrElements = Array("Mo", "Cu", "Fe")
With WorksheetFunction
    J = 1
    For I = 1 To UBound(arrElements)
        arrStainless(J) = .Match(arrElements(I), .Index(vSrc, 1, 0), 0)
        J = J + 1
    Next I
  
'Carbon Steel
arrElements = Array("Mo", "Cu", "Fe")
    J = 1
    For I = 1 To UBound(arrElements)
        arrCarbonSteel(J) = .Match(arrElements(I), .Index(vSrc, 1, 0), 0)
        J = J + 1
    Next I
  
'Chrome
arrElements = Array("W", "Ni", "Cr")
    J = 1
    For I = 1 To UBound(arrElements)
        arrChrome(J) = .Match(arrElements(I), .Index(vSrc, 1, 0), 0)
        J = J + 1
    Next I

'Add other materials using same format

End With

'Might need to use a different Type if not really numbers
lSpool = Application.InputBox("Please enter a value to search for", "Enter Value", Type:=1)

'Dimension results array
'Material
For I = 2 To UBound(vSrc, 1)
    If vSrc(I, 1) = lSpool Then
        sMaterial = vSrc(I, 3)
        Exit For
    End If
Next I
  
lRows = 1 '+1 for the Header row

For I = I To UBound(vSrc, 1)
    If vSrc(I, 1) = lSpool Then lRows = lRows + 1
Next I

Select Case sMaterial
    Case "Stainless Steel"
        arrMaterials = arrStainless
    Case "Carbon Steel"
        arrMaterials = arrCarbonSteel
    Case "Chrome"
        arrMaterials = arrChrome
    Case Else
        MsgBox "Problem with Spool # " & lSpool
        Exit Sub
End Select
      
'Populate results array
ReDim vRes(1 To lRows, 1 To UBound(arrMaterials) + 3)
For I = 1 To 3
    vRes(1, I) = vSrc(1, I)
Next I
For I = 1 To UBound(arrMaterials)
    vRes(1, I + 3) = vSrc(1, arrMaterials(I))
Next I

K = 2
For I = 1 To UBound(vSrc, 1)
    If vSrc(I, 1) = lSpool Then
        For J = 1 To 3
            vRes(K, J) = vSrc(I, J)
        Next J
        For J = 4 To UBound(vRes, 2)
            vRes(K, J) = vSrc(I, arrMaterials(J - 3))
        Next J
        K = K + 1
    End If
Next I
      
With wsRes
    .Cells.Clear
    With .Range("A1").Resize(UBound(vRes, 1), UBound(vRes, 2))
        .Value = vRes
        .ColumnWidth = 255
        .EntireRow.AutoFit
        .EntireColumn.AutoFit
    End With
End With

End Sub

Related Questions

Navigate

• Browse (All)
• Browse A
• Subjects

---

---

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.