VBA Worksheet Data extraction to search for multiple values - vba

I am tasked with pulling two specific rows of data from monthly sheets in a workbook.
Current code, using MyVal and a search box, is only compatible with one search. How can I change the code & searchbox function to be compatible with multiple searches?
Current code looks like this:
Sub Set_Hyper()
' Object variables
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim fFirst As String
' {i} will act as our counter
Dim i As Long
' Use an input box to type in the search criteria
Dim MyVal As String
MyVal = InputBox("What are you searching for", "Search-Box", "")
' if we don't have anything entered, then exit the procedure
If MyVal = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Add a heading to the sheet with the specified search value
With Cells(1, 1)
.Value = "Found " & MyVal & " in the Link below:"
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
i = 2
' Begin looping:
' We are checking all the Worksheets in the Workbook
For Each wks In ActiveWorkbook.Worksheets
If wks.Name <> "Data" Then
' We are checking all cells, we don't need the SpecialCells method
' the Find method is fast enough
With wks.Range("A:A")
' Using the find method is faster:
' Here we are checking column "A" that only have {myVal} explicitly
Set rCell = .Find(MyVal, , , xlWhole, xlByColumns, xlNext, False)
' If something is found, then we keep going
If Not rCell Is Nothing Then
' Store the first address
fFirst = rCell.Address
Do
' Link to each cell with an occurence of {MyVal}
rCell.Hyperlinks.Add Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 2)
Set rCell = .FindNext(rCell)
i = i + 1 'Increment our counter
Loop While Not rCell Is Nothing And rCell.Address <> fFirst
End If
End With
End If
Next wks
' Explicitly clear memory
Set rCell = Nothing
' If no matches were found, let the user know
If i = 2 Then
MsgBox "The value {" & MyVal & "} was not found on any sheet", 64, "No Matches"
Cells(1, 1).Value = ""
End If
' Reset application settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

I'm thinking what you could do is create a UserForm with the following controls:
A text box
A Listbox
A button to add text to the listbox
Another button to run the VBA
The Textbox can hold the search string(s). You can make an event when you click the button to do the following:
1) Add the text from textbox to the listbox. Lookup the AddItem method to do this.
2) Clear the text box contents, so a new value can be added.
Once that's added you can add another for loop around your code to go through each item added to the listbox. That way you can do multiple searches based on what was added.
Hopefully this helps :)

Related

Inserting values from a UserForm to excel sheet which start from a fixed cell?

I have a Cell range Sheets("INVOICE MAKER").Range("D18:D37") (Total 20 Cells), and a little UserForm with name Add Items.
In UserForm there are one Textbox and one Submit Button.
So if I write something in that Textbox and click on Submit Button, Data should be write to next available empty cell in range Sheets("INVOICE MAKER").Range("D18:D37"). And if all 20 cells are filled with data then show a message like "No more rows are available to write data".
Below code don't start writing data from Cell D18, its start writing data from D1.
and doesn't stop after cell D37.
Option Explicit
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("INVOICE MAKER")
lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'check for a part number
If Trim(Me.Textbox.Value) = "" Then
Me.Textbox.SetFocus
MsgBox "Please Type Item Name"
Exit Sub
End If
With ws
.Cells(lRow, 5).Value = Me.Textbox.Value
End With
End Sub
Hope below code will help you:
Public Working_Sheet As Worksheet
Public All_Cell_Value As Boolean
Public Write_Cell_No As Integer
Public Content As String
'When button in the form is clicked
Sub Button1_Click()
Write_Content
End Sub
'validation and content writing function
Public Function Write_Content()
All_Cell_Value = True
Set Working_Sheet = Worksheets("Sheet1")
For i = 18 To 37
If Trim(Working_Sheet.Cells(i, "D")) = "" Then
All_Cell_Value = False
Write_Cell_No = i
Exit For
End If
Next i
If All_Cell_Value = False Then
Content = InputBox("Enter the value")
If Content = "" Then
MsgBox ("No Data")
Else
Working_Sheet.Cells(i, "D").Value = Content
End If
Else
MsgBox ("Sorry content is full")
End If
End Function
Maybe this will help!
EDIT #1
Fix some errors, and the code must to be inside a Form, with the TextBox and the Button
EDIT #2
Added a closing statement for the userform or the macro
Option Explicit
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("INVOICE MAKER") 'Set from Thisworkbook
ws.Activate 'activate the Invoice Maker
'lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Dim iniCell As Integer: iniCell = 18
Dim endCell As Integer: endCell = 37
Dim setCol As Integer: setCol = ws.Range("D1").Column
'As you said, the range is D18:D37, then you can manipulate from this 3 vars
Dim iRange As Range
Dim i As Range
Dim isTheRangeFull As Boolean: isTheRangeFull = False
Dim iMsgbox As Integer
If Trim(Me.TextBox.Value) = "" Then
Me.TextBox.SetFocus
'Ask the user to retry or quit.
iMsgbox = MsgBox("Please Type Item Name" & Chr(10) & "Do you want to retry?", vbYesNo + vbDefaultButton1)
If iMsgbox = 6 Then
GoTo InsertData
'if the user say YES
'do it again
ElseIf iMsgbox = 7 Then
End
'if the user say NO
End If
End If
Set iRange = ws.Range(Cells(iniCell, setCol), Cells(endCell, setCol))
'set your working Range
'This Loop do the job!
For Each i In iRange
isTheRangeFull = True
'if there is no empty cell, won't enter the if, and
'the var continue TRUE, so there is no empty cells...
If i.Value = Empty Then
i.Value = Me.TextBox.Value
isTheRangeFull = False
'the Next line (End) Will close the Form and terminate the macro
'End
'The next line just close the userform
'Unload Me
'Decide which one to uncomment.
Exit For
End If
Next i
If isTheRangeFull Then
MsgBox "No more rows are available to write data"
End
End If
'With ws
' .Cells(lRow, 5).Value = Me.TextBox.Value
'End With
InsertData:
End Sub

VBA - Inserting Check to Validate Correct File is being Selected

In the code below I'm looking to implement a check that verifies the correct file is being selected before executing the rest of the code. Once the 'combinedbook' is open a check will be carried out that verifies certain text is in a certain cell within the workbook. For example, in the code below I need the check to verify that the text "Cash Split" is contained in cell B2 in the combinedWorkbook before carrying out the vlookup and if not to stop executing the code and provide a warning message box.
Sub ImportWriteOffs()
Dim filter As String
Dim caption As String
Dim combinedFilename As String
Dim combinedWorkbook As Workbook
' Open BRAM Report Source Data
MsgBox ("Select 'SRMF0035'")
filter = "Text files (*.xlsx),*.xlsx"
caption = "Select 'SRMF0035'"
combinedFilename = Application.GetOpenFilename(filter, , caption)
If combinedFilename <> "False" Then
Set combinedWorkbook = Application.Workbooks.Open(combinedFilename)
Else
MsgBox "No file was uploaded", vbExclamation
GoTo LastLine
End If
' Conduct Vlookup on BRAM Report
Dim lastRow As Long
With ThisWorkbook.Worksheets("Input Write Offs")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("B9:B" & lastRow).FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[" & combinedWorkbook.Name & "]Tabular Version'!R10C2:R700000C56,55,0)"
combinedWorkbook.Close False
End With
LastLine:
End Sub
Many thanks,
Kieran
What you just need to do here is to have an additional conditional statement to check first if the cell("B2") contained the certain text that you want.
With ThisWorkbook.Worksheets("Input Write Offs")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If .range("B2") = "Cash Split" Then
.Range("B9:B" & lastRow).FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[" & combinedWorkbook.Name & "]Tabular Version'!R10C2:R700000C56,55,0)"
combinedWorkbook.Close False
Else:
Msgbox "Display Prompt In Here"
combinedWorkbook.Close False 'To Ensure that the workbook will be close before ending the routine.
exit sub
End if
End With

VBA Code to Autofill

Have a column H with alphanumeric characters. Some cells in this column have the content (RAM) followed by 5 digits starting from 00000 to 99999.
If cell H219 has the content (RAM) 23596 then i have to fill cell A219 with a comment "completed".
This has to be done for all cells with the content "(RAM) followed by 5 digits"
Sub Macro16_B()
' ' Macro16_B Macro ' '
intRowCount = Worksheets("Reconciliation").UsedRange.Rows.Count
For i = 11 To intRowCount
If InStr(Range("H" & i).Value, "(RAM 00000-99999") Then
Range("A" & i).Value = "Completed"
End If
Next i
End Sub
A non-VBA answer could be (if the cell doesn't have extra text other than (RAM) & 5 numbers):
=IFERROR(IF(LEN(VALUE(TRIM(SUBSTITUTE(H1,"(RAM)",""))))=5,"completed",""),"")
My VBA answer would be:
Sub Test()
Dim rLastCell As Range
Dim rCell As Range
With Worksheets("Reconciliation")
Set rLastCell = .Columns(8).Find("*", , , , xlByColumns, xlPrevious)
If Not rLastCell Is Nothing Then
For Each rCell In .Range(.Cells(1, 8), rLastCell)
If rCell Like "*(RAM) #####*" Then
rCell.Offset(, -7) = "complete"
End If
Next rCell
End If
End With
End Sub
Cheers #Excelosaurus for heads up on the * would've forgotten it as well. :)
One way is to use the Like operator. The precise format of your string is not clear so you may have to amend (and assuming case insensitive). # represents a single number; the * represents zero or more characters.
Sub Macro16_B()
Dim intRowCount As Long, i As Long
' ' Macro16_B Macro ' '
intRowCount = Worksheets("Reconciliation").UsedRange.Rows.Count
For i = 11 To intRowCount
If Range("H" & i).Value Like "(RAM) #####*" Then
Range("A" & i).Value = "Completed"
End If
Next i
End Sub
Well, there are already 2 good answers, but allow me to paste my code here for good measure, the goal being to submerge #user2574 with code that can be re-used in his/her next endeavors:
Sub Macro16_B()
'In the search spec below, * stands for anything, and # for a digit.
'Remove the * characters if you expect the content to be limited to "(RAM #####)" only.
Const SEARCH_SPEC As String = "*(RAM #####)*"
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
'Keep track of some settings.
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
On Error GoTo errHandler
'Prevent Excel from updating the screen in real-time,
'and disable events to prevent unwanted side effects.
Application.ScreenUpdating = False
Application.EnableEvents = False
'Down with business...
Dim scanRange As Excel.Range
Dim cell As Excel.Range
Dim content As String
Dim ramOffset As Long
With ThisWorkbook.Worksheets("Reconciliation").Columns("H")
Set scanRange = .Worksheet.Range(.Cells(11), .Cells(.Cells.Count).End(xlUp))
End With
For Each cell In scanRange
content = CStr(cell.Value2)
If content Like SEARCH_SPEC Then
cell.EntireRow.Columns("A").Value = "Completed"
End If
Next
Recover:
On Error Resume Next
'Restore the settings as they were upon entering this sub.
Application.ScreenUpdating = bScreenUpdating
Application.EnableEvents = bEnableEvents
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Recover
End Sub

VBA Runtime error '1004'. AutoFilter method of Range class failed

Everytime I execute my Macro (below) to search for a string that is entered into my search box, I get a Runtime error '1004'. AutoFilter method of Range class failed. I've tried looking for an answer to this problem on here for a while but nothing seems to provide me with a solution.
When I hit 'Debug' it highlights the below section of the code.
DataRange.AutoFilter _
Field:=myField, _
Criteria1:=SearchString, _
Operator:=xlAnd
I realise that this isn't much info but any help would be extremely appreciated.
P.S. I'm a complete novice with VBA and copied the code off a website that did a step by step guide to creating a search filter in Excel.
Sub SearchBox()
Dim myButton As OptionButton
Dim SearchString As String
Dim ButtonName As String
Dim sht As Worksheet
Dim myField As Long
Dim DataRange As Range
Dim mySearch As Variant
'Load Sheet into A Variable
Set sht = ActiveSheet
'Unfilter Data (if necessary)
On Error Resume Next
sht.ShowAllData
On Error GoTo 0
'Filtered Data Range (include column heading cells)
Set DataRange = sht.Range("A5:Z40000") 'Cell Range
'Set DataRange = sht.ListObjects("Table1").Range 'Table
'Retrieve User's Search Input
mySearch = sht.Shapes("UserSearch").TextFrame.Characters.Text 'Control Form
'mySearch = sht.OLEObjects("UserSearch").Object.Text 'ActiveX Control
'mySearch = sht.Range("A1").Value 'Cell Input
'Determine if user is searching for number or text
If IsNumeric(mySearch) = True Then
SearchString = "=" & mySearch
Else
SearchString = "=*" & mySearch & "*"
End If
'Loop Through Option Buttons
For Each myButton In sht.OptionButtons
If myButton.Value = 1 Then
ButtonName = myButton.Text
Exit For
End If
Next myButton
'Determine Filter Field
On Error GoTo HeadingNotFound
myField = Application.WorksheetFunction.Match(ButtonName, DataRange.Rows(1), 0)
On Error GoTo 0
'Filter Data
DataRange.AutoFilter _
Field:=myField, _
Criteria1:=SearchString, _
Operator:=xlAnd
'Clear Search Field
sht.Shapes("UserSearch").TextFrame.Characters.Text = "" 'Control Form
'sht.OLEObjects("UserSearch").Object.Text = "" 'ActiveX Control
'sht.Range("A1").Value = "" 'Cell Input
Exit Sub
'ERROR HANDLERS
HeadingNotFound:
MsgBox "The column heading [" & ButtonName & "] was not found in cells " & DataRange.Rows(1).Address & ". " & _
vbNewLine & "Please check for possible typos.", vbCritical, "Header Name Not Found!"
End Sub
check the value of myField, it must be between 1 and 26 because your range is A -> Z.

How to loop through worksheets in a defined order using VBA

I have the below working code which loops through each worksheet and if the value defined in the range (myrange) is 'Y', it outputs those sheets into a single PDF document. My challange is that i want to define the order that they are output in the PDF based on the number value in the range (for example 1,2,3,4,5,6,7 etc) instead of 'Y'. I plan on using the same column in the myrange to check whether it needs to be output to PDF, by simply swapping the 'Y' for a number, such as '1' and '2'.
Currently the order is defined based on the location of the worksheet tabs. from left to right.
Any help will be much appreciated.
Sub Run_Me_To_Create_Save_PDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim printOrder As Variant '**added**
Dim myrange
On Error GoTo Errhandler
Sheets("Settings").Activate
' Retrieve value of 'Period Header' from Settings sheet
Range("C4").Activate
periodName = ActiveCell.Value
' Retrieve value of 'File Name' from Settings sheet
Range("C5").Activate
saveAsName = ActiveCell.Value
' Retrieve value of 'Publish PDF to Folder' from Settings sheet
Range("C6").Activate
WhereTo = ActiveCell.Value
Set myrange = Worksheets("Settings").Range("range_sheetProperties")
' Check if Stamp-field has any value at all and if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
' Check whether worksheet should be output in PDF, if not hide the sheet
For Each ws In ActiveWorkbook.Worksheets
Sheets(ws.Name).Visible = True
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
If printOrder = "Y" Then
Sheets(ws.Name).Visible = True
End If
Else: Sheets(ws.Name).Visible = False
End If
Next
'Save the File as PDF
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' Unhide and open the Settings sheet before exiting
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "PDF document has been created and saved to : " & sFileName
Exit Sub
Errhandler:
' If an error occurs, unhide and open the Settings sheet then display an error message
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "An error has occurred. Please check that the PDF is not already open."
End Sub
---------------------- UPDATE: -------------------------------------
Thank you for all your input so far. I did get it to work briefly, but with more playing i've become stuck. I am now receiving a 'Subscript our of range' error with the below code at :
If sheetNameArray(x) <> Empty Then
Any ideas?
Sub Run_Me_To_Create_Save_PDF()
Dim saveAsName As String
Dim WhereTo As String
Dim sFileName As String
Dim ws As Worksheet
Dim myrange
ReDim sheetNameArray(0 To 5) As String
Dim NextWs As Worksheet
Dim PreviousWs As Worksheet
Dim x As Integer
'On Error GoTo Errhandler
Sheets("Settings").Activate
' Retrieve value of 'Period Header' from Settings sheet
Range("C4").Activate
periodName = ActiveCell.Value
' Retrieve value of 'File Name' from Settings sheet
Range("C5").Activate
saveAsName = ActiveCell.Value
' Retrieve value of 'Publish PDF to Folder' from Settings sheet
Range("C6").Activate
WhereTo = ActiveCell.Value
' Check if Stamp-field has any value at all and if not, add the current date.
If Stamp = "" Then Stamp = Date
' Assemble the filename
sFileName = WhereTo & saveAsName & " (" & Format(CDate(Date), "DD-MMM-YYYY") & ").pdf"
Set myrange = Worksheets("Settings").Range("range_sheetProperties")
For Each ws In ActiveWorkbook.Worksheets
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
printOrderNum = printOrder
If printOrderNum <> Empty Then
'Add sheet to array
num = printOrderNum - 1
sheetNameArray(num) = ws.Name
End If
End If
Next
MsgBox Join(sheetNameArray, ",")
'Order Tab sheets based on array
x = 1
Do While Count < 6
If sheetNameArray(x) <> Empty Then
Set PreviousWs = Sheets(sheetNameArray(x - 1))
Set NextWs = Sheets(sheetNameArray(x))
NextWs.Move after:=PreviousWs
x = x + 1
Else
Count = Count + 1
x = x + 1
End If
Loop
Sheets(sheetNameArray).Select
'Save the File as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
' open the Settings sheet before exiting
Sheets("Settings").Activate
MsgBox "PDF document has been created and saved to : " & sFileName
Exit Sub
Errhandler:
' If an error occurs, unhide and open the Settings sheet then display an error message
Sheets("Settings").Visible = True
Sheets("Settings").Activate
MsgBox "An error has occurred. Please check that the PDF is not already open."
End Sub
You would want to define the worksheets in an array.
This example uses a static array, knowing the sheets order and what you want to print in advance. This does work.
ThisWorkbook.Sheets(Array("Sheet1","Sheet2","Sheet6","Master","Sales")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
The problem is that if a sheet is hidden, it will fail on the selection.
So you will need to already know which sheets pass the test to be printed or not before declaring the Array. Therefore you will need a dynamic array to build the list of Worksheets.
I did change how your PrintOrder works, instead of making the sheet invisible, it simply doesn't add it to the array, or vice versa, adds the ones you want to the array. Then you select the array at the end, and run your print macro that works.
I tested this using my own test values, and am trusting that your PrintOrder Test works. But this does work. I used it to print time sheets that only have more than 4 hours per day, and it succeeded, merging 5 sheets out of a workbook with 11 sheets into one PDF.. All of them qualified the test.
TESTED: Insert this instead of your For Each ws and add the Variable Declarations with yours
Sub DynamicSheetArray()
Dim wsArray() As String
Dim ws As Worksheet
Dim wsCount As Long
wsCount = 0
For Each ws In Worksheets
printOrder = Application.VLookup(ws.Name, myrange, 4, False)
If Not IsError(printOrder) Then
If printOrder = "Y" Then
wsCount = wsCount + 1
ReDim Preserve wsArray(1 To wsCount)
'Add sheet to array
wsArray(wsCount) = ws.Name
End If
End If
Next
Sheets(wsArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sFileName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
edit: further explained context of my code to OP
Here is a bit of code I came up with. Basically you would want to take this and adapt it to fit your specific needs but the general idea should work!
Sub MovingPagesAccordingToNumberInRange()
Dim ws As Worksheet
Dim NextWs As Worksheet
Dim PreviousWs As Worksheet
Dim sheetNameArray(0 To 400) As String
Dim i As Integer
'This first loop is taking all of the sheets that have a number
' placed in the specified range (I used Cell A1 of each sheet)
' and it places the name of the worksheet into an array in the
' order that I want the sheets to appear. If I placed a 1 in the cell
' it will move the name to the 1st place in the array (location 0).
' and so on. It only places the name however when there is something
' in that range.
For Each ws In Worksheets
If ws.Cells(1, 1).Value <> Empty Then
num = ws.Cells(1, 1).Value - 1
sheetNameArray(num) = ws.Name
End If
Next
' This next section simply moves the sheets into their
' appropriate positions. It takes the name of the sheets in the
' previous spot in the array and moves the current spot behind that one.
' Since I didn't know how many sheets you would be using I just put
' A counter in the prevent an infinite loop. Basically if the loop encounters 200
' empty spots in the array, everything has probably been organized.
x = 1
Do While Count < 200
If sheetNameArray(x) <> Empty Then
Set PreviousWs = sheets(sheetNameArray(x - 1))
Set NextWs = sheets(sheetNameArray(x))
NextWs.Move after:=PreviousWs
x = x + 1
Else
Count = Count + 1
x = x + 1
End If
Loop
End Sub