I'm trying to create a userform in VBA that will search a list in another sheet and display all matching results, is it also possible to have that data displayed by default to then be narrowed down by the search box value?
There are three columns in the list it will search, but if it finds a match, ideally it would display the data from the first and third, the middle column is irrelevant, but needs to stay for other code.
Then you might need to select one of the results to display it in a specific folder in the workbook (column one result in one cell, column two in the cell next to it).
I'm completely new to userforms so a task like this is quite daunting, I'm not even certain how to activate the form from the sheet.
Any feedback is appreciated, I'll comment any useful code I find online.
Accomplished most of what I was after with the following:
Private Sub SearchButton_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
Workbooks("Form1.xlsm").Worksheets("Employees").Visible = True
ActiveWorkbook.Sheets("Employees").Activate
Employee = EmployeeName.Value
lastrow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("$A$2:$C$" & lastrow).AutoFilter Field:=1, Criteria1:= _
"=*" & Employee & "*", Operator:=xlAnd
Workbooks("Form1.xlsm").Worksheets("Temp").Visible = xlSheetVisible
Workbooks("Form1.xlsm").Worksheets("Temp").Range("A1:AFD1000000").ClearContents
'validation to stop the form breaking if a nane is searched that doesnt exist
Range("A1000000").Select
Selection.End(xlUp).Select
If ActiveCell.Value = "KeyID" Then GoTo validationend
'Take the data that has been filtered by employee name and store it in a temp worksheet
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks("Form1.xlsm").Worksheets("Temp").Activate
Range("A1").Select
ActiveSheet.Paste
'Delete any data that is irrelevant at this stage
Range("D:D").Delete Shift:=xlToLeft
Range("E:E").Delete Shift:=xlToLeft
Range("G:AZ").Delete Shift:=xlToLeft
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Set ws = Worksheets("Temp")
For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Step 1
If ws.Cells(i, 1).Value <> vbNullString Then Me.ListBox.AddItem ws.Cells(i, 1).Value
Next i
validationend:
Workbooks("Form1.xlsm").Worksheets("Form").Activate
'Workbooks("Form1.xlsm").Worksheets("Temp").Visible = xlSheetVeryHidden
'Workbooks("Form1.xlsm").Worksheets("Employees").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrorHandler:
MsgBox ("Error: Name not found. Please check your spelling and try again.")
Workbooks("Form1.xlsm").Worksheets("Form").Activate
'Workbooks("Form1.xlsm").Worksheets("Temp").Visible = xlSheetVeryHidden
'Workbooks("Form1.xlsm").Worksheets("Employees").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Doesn't work perfectly, so if you want more answers, I'll be asking relevant questions soon.
Related
I am trying to write code for a project. There is a preexisting template from the client. I need to create new files by dividing one master excel file into new files. The files must use the template which has multiple worksheets. The data will be separated by Identification numbers, but some files will have thousands of data rows. I am trying to write visual basic code to create the files, but am having some difficulty. Any suggestions are greatly appreciated.
Something like this should be pretty close.
Sub Copy_With_AutoFilter2()
'Note: This macro use the function LastRow
'Important: The DestSh must exist
Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
'Set the destination worksheet
'Note: the sheet "RecordsOfTheNetherlands" must exist in your workbook
Set DestSh = Sheets("RecordsOfTheNetherlands")
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Firstly, remove the AutoFilter
My_Range.Parent.AutoFilterMode = False
'Filter and set the filter field and the filter criteria :
'This example filter on the first column in the range (change the field if needed)
'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
'Use "<>Netherlands" as criteria if you want the opposite
My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands"
'If you want to filter on a cell value you can use this, use "<>" for the opposite
'This example uses the activecell value
'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value
'This will use the cell value from A2 as criteria
'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value
''If you want to filter on a Inputbox value use this
'FilterCriteria = InputBox("What text do you want to filter on?", _
' "Enter the filter item.")
'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria
'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else
'Copy the visible data and use PasteSpecial to paste to the Destsh
With My_Range.Parent.AutoFilter.Range
On Error Resume Next
' Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'Copy and paste the cells into DestSh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Delete the rows in the My_Range.Parent worksheet
'rng.EntireRow.Delete
End If
End With
End If
'Close AutoFilter
My_Range.Parent.AutoFilterMode = False
'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
https://www.rondebruin.nl/win/s3/win006_2.htm
I'm working on a macro that will search a List sheet for different counties and then paste the entire row onto the current sheet. I have a worksheet for each person (named Mark, John, etc.) and each person is assigned several counties. Mark has three counties, listed in cells J1:L1, which I've named as a range (MyCounties). I need a macro that will look through Sheet "List" column "I" for each of those counties and copy the entire row onto Sheet "Mark" starting at "A4". I'm using a modified macro I found on here, but I must be doing something wrong. It is currently giving me an error "Application defined or object defined error" in regards to Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
Sub NewSheetData()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Rng As Range, rCell As Range
Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
For Each rCell In Range("MyCounties")
On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:=rCell.Value
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
Next rCell
Application.EnableEvents = True
End Sub
This code will need to be adjusted to accommodate your named ranges and worksheet names. It currently uses named ranges with worksheet scope from each worksheet.
Sub NewSheetData()
Dim w As Long, sWSs As Variant, vCrit As Variant, rw As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
sWSs = Array("Mark", "John", "etc")
For w = LBound(sWSs) To UBound(sWSs)
With Worksheets(sWSs(w))
vCrit = .Range("MyCounties").Value2
rw = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 4)
End With
With Worksheets("List")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(4, "I"), .Cells(.Rows.Count, "I").End(xlUp))
.AutoFilter field:=1, Criteria1:=vCrit, Operator:=xlFilterValues
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Cells)) Then
.Cells.EntireRow.Copy Destination:=Worksheets(sWSs(w)).Cells(rw, "A")
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Next w
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
This uses the values from each worksheet's MyCounties named range as an array of criteria for .AutoFilter. using an array as criteria requires the Operator:=xlFilterValues parameter. It also checks to make sure that there are filtered values to copy before copying them.
may be your EntireRow is copying rows whose first column is blank
you could use UsedRange property of worksheet object to get the last used row
furthermore you'd better place With Rng oustide the loop, since it doesn't change with it
Option Explicit
Sub NewSheetData()
Dim Rng As Range, rCell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("List")
Set Rng = .Range("I4", .Range("I" & .Rows.Count).End(xlUp))
End With
With Rng
For Each rCell In Range("MyCounties")
.AutoFilter , Field:=1, Criteria1:=rCell.Value
If Application.WorksheetFunction.Subtotal(103, .cells) > 1 Then .Resize(.Rows.Count - 1).Offset(1).EntireRow.Copy _
Sheets("Sheeta2").Range("A" & Sheets("Sheeta2").UsedRange.Rows(Sheets("Sheeta2").UsedRange.Rows.Count).Row).Offset(1)
Next
.Parent.AutoFilterMode = False
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I have some code where I am using index(match) based on a cell with a dropdown menu. When users select a certain security, a CUSIP is outputted which then pastes formulas from bloomberg to output the data into excel.
I then proceed to create a table but would like to filter the table using autofilter and delete the rows that dont meet the filter criteria but that doesnt seem to be working for some reason! I also have insrted an activex control form button so that when a user double clicks on the dropdown menu they can search for a security and it would autocomplete.
Please help, Thanks!
Sub INDEX_MATCH_CUSIP_TO_SHORTDESCRIPTION()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sheet4").Range("B3:E100").Delete
Range("B2").Select
test = Application.WorksheetFunction.Index(Sheets("DEX Spread Report (Corp)").Range("B7:B1600"), Application.WorksheetFunction.Match(ActiveCell.Value, Sheets("DEX Spread Report (Corp)").Range("D7:D1600"), 0), 1)
ActiveCell.Offset(1, 0).Value = test
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BBRG_FORMULAS_FOR_SECURITY()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim CUSIPS As String
Sheets("Sheet4").Select
Range("B2").Select
CUSIPS = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(2, 0).Value = "=BDS(""" & CUSIPS & """ & ""& CUSIP"",""ALL_HOLDERS_PUBLIC_FILINGS"", ""STARTCOL=1"", ""ENDCOL=1"")"
ActiveCell.Offset(2, 1).Value = "=BDS(""" & CUSIPS & """ & ""& CUSIP"",""ALL_HOLDERS_PUBLIC_FILINGS"", ""STARTCOL=6"", ""ENDCOL=8"")"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Create_Table_and_AutoFilter()
Dim wksDest As Worksheet
Dim LastRow As Long
Dim rng As Range
Dim rngDelete As Range
Sheets("Sheet4").Select
Set wksDest = Worksheets("Sheet4")
LastRow = Cells(Rows.Count, 2).End(xlUp).row
LastRow1 = Cells(Rows.Count, 2).End(xlUp).row
ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(4, 2), Cells(LastRow, 5)), , xlYes).Name = "HoldersTable"
With wksDest
Set rng = Range(Cells(4, 2), Cells(LastRow1, 5))
rng.AutoFilter Field:=1, Criteria1:="<=1000"
Set rngDelete = rng.SpecialCells(xlCellTypeVisible)
rng.AutoFilter
rngDelete.EntireRow.Delete
End With
End Sub
you're most probably trying to delete table header
try substituting the code from With wksDestto End With with the following snippet:
With wksDest.Range(Cells(4, 2), Cells(LastRow1, 5))
.AutoFilter Field:=1, Criteria1:="<=1000"
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(,1)) > 1 Then .offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
I have written the below script to copy a range of data from one sheet to another workbook based on a set of criteria. I now need to add an extra piece to filter this acceptable data to different sheets named after the values in column G and if the value doesn't already exist to create the sheet named after the value. For example if column G value = JULA then to copy this to sheet JULA however if this doesn't already exist then to create and copy.
Private Sub cmdArchive_click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim LastRow As Integer, i As Integer, erow As Integer
iForm = ("\\Insurance\It\FileData\Computers\Release Note\Collated Release Records\Master.xlsx")
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
If Cells(i, 1) <> "" And Cells(i, 9) = "" And Cells(i, 9) = "" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
workbooks.Open Filename:=iForm
Worksheets("Scheduled Forms").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
MsgBox ("iForms have been archived, please clear the Team Release notes ready for the next implimentation window"), vbInformation + vbOKOnly, "Complete!"
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thank you in advance.
I have a spreadsheet named Data Sheet that collects data from other worksheets via formulas and works perfectly. I need a macro that will copy the data from multiple rows so I can paste into a separate workbook.
I have 30 rows of data ranging from A3:EI3 to A32:EI32. This data is collected from 1 to 30 other sheets if they are made visible and data entered. Here is the tricky part: I only want to collect the data from the visible sheets.
Here is an example of the flow I am looking for: Sheet 1 is always visible and never is hidden. Sheet 2, Sheet 3, and Sheet 4 are visible, but Sheet 5 through Sheet 30 are still hidden. Data Sheet has already collected the data from the visible sheets, but the remaining rows (Sheets 5-30) all show 0 in the data cells.
I now want to run a macro that will copy the data (to the clipboard) from Data Sheet Row 3 (represents Sheet 1), Row 4 (represents Sheet 2), etc. and allow me to paste into the next available row in another workbook.
Here is the code that works for a single row of data.
VBA Code:
Sub CopyDataSheet()
'
' CopyDataSheet Macro
'
Application.ScreenUpdating = False
Sheets("Data Sheet").Visible = True
Sheets("Data Sheet").Select
Rows("3:3").Select
Selection.Copy
Rows("1:1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E1:EF1").Select
Application.CutCopyMode = False
Selection.NumberFormat = "0"
Rows("1:1").Select
Range("B1").Activate
Selection.Copy
Sheets("Sheet 1").Select
Range("a38").Select
Sheets("Data Sheet").Visible = True
Application.ScreenUpdating = True
MsgBox "YOU HAVE CAPTURED ALL ENTERED DATA..." & _
vbCrLf & vbCrLf & "CLICK OK" _
& vbCrLf & vbCrLf & "PASTE INTO NEXT EMPTY LINE OF DATA SHEET", _
vbInformation, ""
End Sub
I'm not 100% sure what it is you are trying to do, but I think I can supply a few code fragments that may help you.
This will cycle through the sheets in an active workbook and allow you to do something based on whether or not the sheet is visible:
j = ActiveWorkbook.Sheets.Count
For i = 1 To j
Select Case Sheets(i).Visible
Case xlSheetVisible
'Do something if the sheet is visible
Case Else
'Do something when the sheet is not visible
End Select
Next i
To get the next available row there are many different ways. One of the easiest is simply this:
next_row = Range("A" &
Rows.Count).End(xlUp).row + 1
This assumes that column A will always have a value in any data rows. If this is not the case you may want to try this:
next_row = ActiveSheet.UsedRange.Rows.Count + 1
Neither is bullet proof, but it should at least give you a start.
Option Explicit
Public Sub CollectData()
Dim wsCrnt As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim lRowCrnt As Long
Dim lRowDest As Long
On Error GoTo Err_Hnd
ToggleInterface False
Set wsDest = ThisWorkbook.Worksheets("Data Sheet")
lRowDest = wsDest.UsedRange.Rows.Count + 1&
For Each wsCrnt In ThisWorkbook.Worksheets
If wsCrnt.Visible = xlSheetVisible Then
If Not wsCrnt Is wsDest Then
For lRowCrnt = 1& To 30&
If Excel.WorksheetFunction.CountA(wsCrnt.Rows(lRowCrnt)) Then
wsCrnt.Rows(lRowCrnt).Copy
wsDest.Rows(lRowDest).PasteSpecial xlPasteValues
lRowDest = lRowDest + 1
End If
Next
End If
End If
Next
Exit_Proc:
On Error Resume Next
ToggleInterface True
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbCritical Or vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
Resume Exit_Proc
End Sub
Private Sub ToggleInterface(ByVal interfaceOn As Boolean)
With Excel.Application
.Cursor = IIf(interfaceOn, xlDefault, xlWait)
.StatusBar = IIf(interfaceOn, False, "Working...")
.EnableEvents = interfaceOn
.Calculation = IIf(interfaceOn, xlCalculationAutomatic, xlCalculationManual)
.ScreenUpdating = interfaceOn
.EnableCancelKey = Abs(interfaceOn)
End With
End Sub