Problem: I need to search a list of worksheets in the active workbook and return the name of every worksheet that has a cell whose value matches a search input. The names of these worksheets need to then populate a userform combobox with duplicates.
Partial Solution: I've been able to reverse-engineer a piece of code that does most of the above. However, the worksheet names currently populate a msgbox with duplication. How would I make this result populate a combobox instead?
I've been experimenting with outputting to a collection as well as writing results to a new worksheet, but these option are still in the conceptual phase, so I have no code to post.
UPDATE (some code):
Public Sub FindDate()
'find date data on all sheets
Dim ws As Worksheet
Dim rngFind As Range
Dim myDate As String
Dim firstAddress As String
Dim addressStr As String
Dim findNum As Integer
Dim sheetArray(299) As Integer
Dim arrayIndex As Integer
myDate = InputBox("Enter date to find")
If myDate = "" Then Exit Sub
For Each ws In ActiveWorkbook.Worksheets
'Do not search the following sheets
With ws
If ws.Name = "CM Chapters" Then GoTo myNext
If ws.Name = "CM Codes" Then GoTo myNext
If ws.Name = "PCS Categories" Then GoTo myNext
If ws.Name = "PCS Chapters" Then GoTo myNext
If ws.Name = "PCS Code" Then GoTo myNext
Set rngFind = .Columns(41).Find(what:=myDate, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not rngFind Is Nothing Then
firstAddress = rngFind.Address
Do
findNum = findNum + 1
addressStr = addressStr & .Name & vbCrLf
''''Original working code
' addressStr = addressStr & .Name & " " & rngFind.Address & vbCrLf
''''Modified to remove excess text
Set rngFind = .Columns(41).FindNext(rngFind)
Loop While Not rngFind Is Nothing And rngFind.Address <> firstAddress
End If
myNext:
End With
Next ws
If Len(addressStr) Then
'''' Original working code
' MsgBox "Found: "" & myDate & "" " & findNum & " times." & vbCr & _
' addressStr, vbOKOnly, myDate & " found in these cells"
'''' Modified to to remove excess text
MsgBox vbCr & addressStr
Else:
MsgBox "Unable to find " & myDate & " in this workbook.", vbExclamation
End If
End Sub
Try this
Do
findNum = findNum + 1
addressStr = addressStr & .Name
ComboBox1.AddItem addressStr 'replace ComboBox1 with your ComboBox name
addressStr = addressStr & vbCrLf ' if you still want to add the Line feed
Set rngFind = .Columns(41).FindNext(rngFind)
Loop While Not rngFind Is Nothing And rngFind.Address <> firstAddress
Got it. Here's the final working code. Slight changes in where the variables pass to, based on additional steps not included in original question.
Private Sub CboReviewWeek_Change()
'search all worksheets for matching date and return worksheet names to combobox
Dim ws As Worksheet
Dim rngFind As Range
Dim myDate As Date
Dim firstAddress As String
Dim StrTab As String
'Sets the variable equal to date selected
myDate = CboReviewWeek.Value
'object to operate on
For Each ws In ActiveWorkbook.Worksheets
'Exclude the following sheets from search
With ws
If ws.Name = "CM Chapters" Then GoTo myNext
If ws.Name = "CM Codes" Then GoTo myNext
If ws.Name = "PCS Categories" Then GoTo myNext
If ws.Name = "PCS Chapters" Then GoTo myNext
If ws.Name = "PCS Code" Then GoTo myNext
'Run Find command on defined range and save result to range variable
Set rngFind = .Columns(40).Find(what:=myDate, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
'If cell is populated, then pass said value to string variable
If Not rngFind Is Nothing Then
firstAddress = rngFind.Address
Do 'do this thing
'set string variable equal to name of worksheet
StrTab = .Name
'Add string variable value to Combobox
Me.CboReviewModule.AddItem StrTab
Loop While rngFind.Address <> firstAddress And Not rngFind Is Nothing
'Reset the range to next worksheet and run find again
Set rngFind = .Columns(40).FindNext(rngFind)
End If
End With
myNext:
Next ws
End Sub
Related
EDIT: Code updated to reflect advice presented in comment. I am currently getting a 1004 error on the "Set RefList" line.
Background
Sheet 1 or "User Picklist" contains a header row (row 11) with variable titles. The headers will vary based on the client, as will the values that correspond to each header (listed in that same column beginning row 12).
Sheet 2 or "User List" contains the actual users to be uploaded to our system. We frequently see users inputting values that don't exist on the picklist.
The Objective
I want to set up flexible data validation on page 2 (User List) where each cell references its own column header (so Range("C13") would reference Range("C11").Value), then search for that value in row 11 of Page 1(User Picklist). When it finds that value, it will use the picklist in that column only as its list of values for data validation.
So if Range("C11").Value on Page 2 is "Location", it does a .Find on row 11 on Page 1, and if it finds Location it will add data validation based on the subsequent values in that column.
The Code
'Remove Case Sensitivity
Option Compare Text
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim RefRng As Range, NewRng As Range
Set ws = ThisWorkbook.Worksheets("User Picklist")
Dim RefList As Range
Set RefRng = ws.Range("A12:T123")
Set NewRng = Range("A12:T101")
Dim c As Range
Application.Calculation = xlCalculationManual
For Each c In NewRng
Dim var1 As String
Dim var2 As String
var1 = Cells(11, c.Column).Value
Dim RngFind As Range
Set RngFind = ws.Range("A11:ZZ11").Find(var1)
If Not RngFind Is Nothing Then
Set RefList = Range(RngFind.Offset(1, 0), RngFind.Offset(1, 0).End(xlDown))
With c.Validation
.Delete 'delete previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=" & ws.Name & "'!" & RefList.Address
End With
End If
ActiveWorkbook.Sheets("User List").Calculate
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
As of right now this is crashing my document every time, and my guess is it's because doing this one cell at a time in my For loop is inefficient. I haven't been able to come up with any other way of being able to evaluate the header relative to each cell in my range though.
Any advice is appreciated! :)
This might be a little better-behaved:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim RefRng As Range, RngFind As Range, NewRng As Range, hdr
Dim RefList As Range, c As Range, rngHeaders As Range, Msg
On Error GoTo ErrHandling
Set ws = ThisWorkbook.Worksheets("User Picklist")
'only deal with the selected cell(s)
Set NewRng = Application.Intersect(Me.Range("A12:T101"), Target)
If Not NewRng Is Nothing Then
Set rngHeaders = ws.Range("A11:ZZ11")
For Each c In NewRng
c.Validation.Delete 'delete previous validation
hdr = Me.Cells(11, c.Column).Value
If Len(hdr) > 0 Then
Set RngFind = rngHeaders.Find(hdr, , xlValues, xlWhole)
'matched header?
If Not RngFind Is Nothing Then
Set RefList = ws.Range(RngFind.Offset(1, 0), _
RngFind.Offset(1, 0).End(xlDown))
c.Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:="='" & ws.Name & "'!" & RefList.Address
End If 'matched header
End If 'has header
Next c
End If 'in required range
Here:
Application.ScreenUpdating = True
Exit Sub
ErrHandling:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " & _
Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
Debug.Print Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Resume Here
End Sub
I have a table sort of like this:
Pendergrass (606)-663-4567
Rich (606)-667-4567
Scott (606)-987-4567
Dennis (606)-233-4567
David (606)-888-4567
Red (606)-567-4567
Wendy (606)-765-4567
Todd (606)-677-4567
Andrea (606)-780-3451
Caroline (606)-992-7865
and the code I'm using looks like this:
Private Sub CommandButton2_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
'If ws.Name <> Worksheets("Report").Name Then
If ws.Name = "Sheet1" Then
With ws.Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
With Worksheets("Report")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = rFound.Value
End With
End If
Next a
End With
End If
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub
I would like if to take the numbers of David, Andrea and Caroline and put them any where in the Report page. This only grabs one.
Can anyone suggest where I am going wrong with this code?
Try the code below.
However, not sure why you are looping through all the sheets with For Each ws In ThisWorkbook.Worksheets , if at the following line you are checking If ws.Name = "Sheet1" Then.
You can replace the lines below (remove a For, a With and If) :
For Each ws In ThisWorkbook.Worksheets
With ws
'If ws.Name <> Worksheets("Report").Name Then
If .Name = "Sheet1" Then
With .Range("A1:E30").Cells
with a simple:
With Worksheets("Sheet1").Range("A1:E30").Cells
Code
Private Sub CommandButton2_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
With ws
'If ws.Name <> Worksheets("Report").Name Then
If .Name = "Sheet1" Then
With .Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1) = rFound.Value
Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(, 1) = rFound.Offset(, 1).Value
End If
Next a
End With
End If
End With
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub
I've tried changing everywhere there was a cell to a range and other things but I can't figure it out. I'd like for the code to search the entire sheet, instead of one cell, for these names and paste the information of the cell to the right of it to the other sheet.
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet, myCounter As Long
Dim erow As Long, myValue As Long
Dim nextValue As Long
For Each ws In ThisWorkbook.Sheets
With ws
Select Case .Range("C3").Value
Case "David", "Andrea", "Caroline"
myCounter = 1 ' raise flag >> found in at least 1 sheet
' get first empty row in "Report" sheet
erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Report").Cells(erow, 1) = .Range("C3").Value
End Select ' Select Case .Range("C3").Value
End With
Next ws
If myCounter = 0 Then
MsgBox "None of the sheets contains the names " & Chr(10) & " 'David', 'Andrea', 'Caroline' in cell C3 ", vbInformation, "Not Found"
End If
End Sub
You can use Application.Match with array version. Substitute this for your loop:
Dim ar, r
For Each ws In ThisWorkbook.Sheets
ar = Application.match(Array("David", "Andrea", "Caroline"), ws.Columns("C"), 0)
For Each r In ar
If Not IsError(r) Then
myCounter = 1 ' raise flag >> found in at least 1 sheet
erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).row
Worksheets("Report").Cells(erow, 1) = ws.Range("C" & r).value
Worksheets("Report").Cells(erow, 2) = ws.Range("D" & r).value
End If
Next r
Next ws
Notice though, that this will find you only one match for each word, the first one. If each word can be repeated many times and you want to find all matches, it will need some modification.
Multiple rows and multiple columns would be better served by the Find command.
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
'If ws.Name <> Worksheets("Report").Name Then
If ws.Name = "Sheet7" Then
With ws.Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
With Worksheets("Report")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = rFound.Value
End With
End If
Next a
End With
End If
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub
I'm struggling with the following code which you can see below. It is totally a pain in the *** now. I really need some help.
This code is a search tool which looks for criteria from every worksheet except the summary and the list. After the .Find founds the word, then the code selects a 4 wide range around the searched word, then it copies and pastes it on the Summary sheet.
When the first searched word is found, I also would like to copy and paste the actual worksheet (where the word is found) title (on each worksheet "G3:J3") right after the search result on the summary page. This search tool could help me to find quickly which search criteria where can be found, at which sheet and some properties which also inside the title.
The result should look like this: (r1 = the first 4 columns, r2= the rest 4 columns (that is the excel header))
item nr. Item Owner Used Capacity ESD_nr. box Owner Free capacity location
Sorry for the long description.
CODE:
Private Sub searchTool()
Dim ws As Worksheet, OutputWs As Worksheet, wbName As Worksheet
Dim rFound As Range, r1 As Range, r2 As Range, multiRange As Range
Dim strName As String
Dim count As Long, lastRow As Long
Dim IsValueFound As Boolean
IsValueFound = False
Set OutputWs = Worksheets("Summary") '---->change the sheet name as required
lastRow = OutputWs.Cells(Rows.count, "K").End(xlUp).Row
On Error Resume Next
strName = ComboBox1.Value
If strName = "" Then Exit Sub
For Each ws In Worksheets
If ws.Name <> "lists" And ws.Name <> "Summary" Then
With ws.UsedRange
Set rFound = .Find(What:=strName, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFound Is Nothing Then
firstAddress = rFound.Address
Do
IsValueFound = True
Set r1 = Range(rFound.EntireRow.Cells(1, "B"), rFound.EntireRow.Cells(1, "D"))
Set r2 = Range("G3:J3")
Set multiRange = Application.Union(r1, r2)
multiRange.Copy
OutputWs.Cells(lastRow + 1, 11).PasteSpecial xlPasteAll
Application.CutCopyMode = False
lastRow = lastRow + 1
Set rFound = .FindNext(rFound)
Loop While Not rFound Is Nothing And rFound.Address <> firstAddress
End If
End With
End If
Next ws
On Error GoTo 0
If IsValueFound Then
OutputWs.Select
MsgBox "Seach complete!"
Else
MsgBox "Name not found!"
End If
End Sub
I must admit I had trouble following your requirements and there was not a definition of where it wasn't working, to that end I re-wrote it to help me understand.
Private Sub SearchTool_2()
Dim BlnFound As Boolean
Dim LngRow As Long
Dim RngFind As Excel.Range
Dim RngFirstFind As Excel.Range
Dim StrName As String
Dim WkShtOutput As Excel.Worksheet
Dim WkSht As Excel.Worksheet
StrName = "Hello" 'ComboBox1.Value
If StrName = "" Then Exit Sub
Set WkShtOutput = ThisWorkbook.Worksheets("Summary")
LngRow = WkShtOutput.Cells(WkShtOutput.Rows.count, "K").End(xlUp).Row + 1
For Each WkSht In ThisWorkbook.Worksheets
If (WkSht.Name <> "lists") And (WkSht.Name <> "Summary") Then
With WkSht.UsedRange
Set RngFind = .Find(What:=StrName, LookIn:=xlValues, LookAt:=xlWhole)
If Not RngFind Is Nothing Then
Set RngFirstFind = RngFind
BlnFound = True
Do
WkSht.Range(RngFind.Address & ":" & WkSht.Cells(RngFind.Row, RngFind.Column + 2).Address).Copy WkShtOutput.Range(WkShtOutput.Cells(LngRow, 11).Address)
WkSht.Range("G3:J3").Copy WkShtOutput.Range(WkShtOutput.Cells(LngRow + 1, 11).Address)
LngRow = LngRow + 2
Set RngFind = .FindNext(RngFind)
Loop Until RngFind.Address = RngFirstFind.Address
End If
End With
End If
Next
Set WkShtOutput = Nothing
If BlnFound Then
ThisWorkbook.Worksheets("Summary").Select
MsgBox "Seach complete!"
Else
MsgBox "Name not found!"
End If
End Sub
I found the copy statement was the better option rather than using the clipboard, I also found a missing reference of firstAddress.
i need to copy data from one sheet to another and paste into the next available row where the column headings match.
I am having difficulty creating the range to copy into.
this seems to be the issue -
rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Combined Totals").Range(tCell.Offset(1) & lRow)
i ahve tried creating the destination to paste to using Cells and Range, but i can't seem to add variables into the syntax correctly.
What am i doing wrong?
Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("OPT 1 Total")
With ws
'~~> Find the cell which has the name
Set sCell = .Range("A1:Z1").Find("MN")
Set tCell = Sheets("Combined Totals").Range("A1:Z1").Find("MN")
'~~> If the cell is found
If Not sCell Is Nothing Then
'~~> Get the last row in that column and check if the last row is > 1
lRow = .Range(Split(.Cells(, sCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row
If lRow > 1 Then
'~~> Set your Range
Set rng1 = .Range(sCell.Offset(1), .Cells(lRow, sCell.Column))
'bCell.Offset(1).Activate
Debug.Print tCell.Address
rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Combined Totals").Range(tCell.Offset(1) & lRow)
'Cells(2, 1).Resize(rng1.Rows.Count) '
'~~> This will give you the address
Debug.Print rng1.Address
End If
End If
End With
EDIT2: parameterized....
Sub CopyAll()
TransferToTotals "OPT 1 Total", Array("MN", "TX", "CA")
TransferToTotals "OPT 2 Total", Array("MN", "TX", "CA")
End Sub
Sub TransferToTotals(srcSheet As String, arrHeaders)
Dim ws As Worksheet, sCell As Range, tCell As Range, lstCell As Range
Dim wsd As Worksheet, i As Long, arrHeadings
Set wsd = ThisWorkbook.Sheets("Combined Totals")
On Error Resume Next
Set ws = ThisWorkbook.Sheets(srcSheet)
On Error GoTo 0
If ws Is Nothing Then
Debug.Print "Source sheet '" & srcSheet & "' not found!"
Exit Sub
End If
For i = LBound(arrHeaders) To UBound(arrHeaders)
With ws
Set sCell = .Range("A1:Z1").Find(arrHeaders(i))
Set tCell = wsd.Range("A1:Z1").Find(arrHeaders(i))
If Not sCell Is Nothing And Not tCell Is Nothing Then
Set lstCell = .Cells(.Rows.Count, sCell.Column).End(xlUp)
If lstCell.Row > 1 Then
'EDIT - paste values only...
.Range(sCell.Offset(1), lstCell).SpecialCells( _
xlCellTypeVisible).Copy
wsd.Cells(Rows.Count, tCell.Column).End(xlUp) _
.Offset(1, 0).PasteSpecial xlPasteValues
End If
Else
Debug.Print "Couldn't find both '" & _
arrHeaders(i) & "' headers"
End If
End With
Next i
End Sub