Assiging certain text in a cell column headings to return Hi! I need some help w
ID: 3561582 • Letter: A
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.10Explanation / 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