Why is my match row function not being entered? - excel

I have a userform that is pulling in data from a worksheet into the userform fields. I have a function that matches the row of that employee if the employee number in userform is found in column F.
It used to work but now it doesn't even enter the function to determine if that employee exists in the data.
Private Sub CommandButton2_Click()
On Error Resume Next
Dim wb As Workbook: Set wb = Workbooks.Open("J:\HRIS Team\Analytics\Headcount Tracking File.xlsx")
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim lString As String, lArray() As String
lString = cmbEmployee.Value
lArray = Split(lString, " - ")
Dim recRow As Range
If optEmployeeName.Value = True And optEmployeeID.Value <> True Then
Set recRow = MatchRow(ws.Range("A1").CurrentRegion, _
lArray(1))
Else
Set recRow = MatchRow(ws.Range("A1").CurrentRegion, _
lArray(0))
End If
If recRow Is Nothing Then MsgBox "Employee not found"
With recRow.EntireRow
Me.cmbFunction.Value = .Cells(1).Value
Me.cmbHRBP.Value = .Cells(3).Value
Me.cmbRequestType.Value = .Cells(4).Value
Me.cmbMovementType.Value = .Cells(7).Value
Me.txtEffectiveDate.Value = .Cells(8).Value
Function MatchRow(tablerange As Range, lArray) As Range
Dim rw As Range
Dim lString_2 As String, lArray_2() As String
lString_2 = cmbEmployee.Value
lArray_2 = Split(lString_2, " - ")
For Each rw In tablerange.Rows
If optEmployeeName.Value = True Then
If CStr(rw.Cells(6).Value) = Trim(lArray_2(1)) Then
Set MatchRow = rw
Exit Function
End If
ElseIf optEmployeeID.Value = True Then
If CStr(rw.Cells(6).Value) = Trim(lArray_2(0)) Then
Set MatchRow = rw
Exit Function
End If
End If
Next rw
End Function
I hover over to make sure it's getting the employee ID correctly from the lArray, and its there. I can't figure out the reasoning behind why it wouldn't even attempt to enter the matchrow function. Any ideas?

Related

Using worksheet position and range.value

I've got a code that generates a workbook by copying and moving selected worksheets into a new workbook.
The first page of this new workbook is a summary page. On this i want to pull data from the subsequent worksheets by using the range.value method.
However can I use this when referencing the worksheet location for example
Dim wb As Workbook, wbAll As Workbook
Dim ws As Worksheet
Set wbAll = Workbooks.Add
On Error Resume Next
For t = 1 To 100
Set wb = Workbooks("Book" & t)
For Each ws In wb.Sheets
ws.Move after:=wbAll.Sheets(Sheets.Count)
Next
Next
Workbooks("Book" & t).Activate
ActiveWorkbook.Sheets("Sheet1").Select
'compile worksheets into list
Dim wss As Worksheet
Dim x As Integer
On Error Resume Next
x = 17
Sheets("Sheet1").Range("c17:E46").ClearContents
For Each wss In ActiveWorkbook.Worksheets
If wss.Name <> "Sheet1" Then
Sheets("Sheet1").Cells(x, 3) = wss.Name
x = x + 1
End If
Next wss
'COMPILE COSTS
ActiveWorkbook.Sheet1.Range("C17").Value = ActiveWorkbook.Worksheet(2).Range("Q118").Value
ActiveWorkbook.Sheet1.Range("C18").Value = ActiveWorkbook.Worksheet(3).Range("Q118").Value
.
.
ActiveWorkbook.Sheet1.Range("C45").Value = ActiveWorkbook.Worksheet(30).Range("Q118").Value
ActiveWorkbook.Sheet1.Range("C46").Value = ActiveWorkbook.Worksheet(31).Range("Q118").Value
'Compile WBS
ActiveWorkbook.Sheet1.Range("D17").Value = ActiveWorkbook.Worksheet(2).Range("D10").Value
ActiveWorkbook.Sheet1.Range("D18").Value = ActiveWorkbook.Worksheet(3).Range("D10").Value
.
.
ActiveWorkbook.Sheet1.Range("D45").Value = ActiveWorkbook.Worksheet(30).Range("D10").Value
ActiveWorkbook.Sheet1.Range("D46").Value = ActiveWorkbook.Worksheet(31).Range("D10").Value
'Week Number name
ActiveWorkbook.Sheet1.Range("C10").Value = ActiveWorkbook.Worksheet(2).Range("D4").Value
'Supplier Name
ActiveWorkbook.Sheet1.Range("C12").Value = ActiveWorkbook.Worksheet(2).Range("D5").Value
This however gives me an error message of object defined error
This may help:
EDIT: updated to show using links instead of copying the values from the sheet.
Sub Tester()
Dim wb As Workbook, wbAll As Workbook
Dim ws As Worksheet
Dim wss As Worksheet
Dim x As Integer, wsSummary, t As Long
Set wbAll = Workbooks.Add
For t = 1 To 100
Set wb = Nothing
On Error Resume Next 'ignore any error
Set wb = Workbooks("Book" & t)
On Error GoTo 0 'cancel OERN as soon as possible
If Not wb Is Nothing Then
For Each ws In wb.Sheets
ws.Move after:=wbAll.Sheets(wbAll.Sheets.Count)
Next
End If
Next
'Workbooks("Book" & t).Activate 'not sure what this is for?
'ActiveWorkbook.Sheets("Sheet1").Select
'compile worksheets into list
x = 17
Set wsSummary = wbAll.Sheets("Sheet1")
wsSummary.Range("C17:E46").ClearContents
For Each wss In wbAll.Worksheets
If wss.Name <> wsSummary.Name Then
With wsSummary.Rows(x)
'.Cells(3).Value = wss.Name
InsertLink .Cells(5), wss.Range("A1"), "=SheetName({1})"
'.Cells(4).Value = wss.Range("Q118").Value
InsertLink .Cells(4), wss.Range("Q118") 'create a link
'.Cells(5).Value = wss.Range("D10").Value
InsertLink .Cells(5), wss.Range("D10")
'etc etc
End With
x = x + 1
End If
Next wss
End Sub
'UDF to return the sheet name
Function SheetName(c As Range)
Application.Volatile
SheetName = c.Parent.Name
End Function
'Insert a worksheet formula into a cell (rngDest), where the precedents
' are either a single cell/range or an array of cells/ranges (SourceRange)
' sTemplate is an optional string template for the formula
' eg. "=SUM({1},{2})" where {1} and {2} are ranges in SourceRange
' Empty template defaults to "={1}"
'Useage:
' InsertLink sht1.Range("A1"), Array(sht1.Range("B1"), sht1.Range("C1")), "=SUM({1},{2})"
Sub InsertLink(rngDest As Range, SourceRange As Variant, Optional sTemplate As String)
Dim i As Long, sAddress As String, arrTmp As Variant
If sTemplate = "" Then sTemplate = "={1}" 'default is a simple linking formula
'got a single range, or an array of ranges?
If TypeName(SourceRange) = "Range" Then
arrTmp = Array(SourceRange) 'make an array from the single range
Else
arrTmp = SourceRange 'use as-is
End If
'loop over the input range(s) and build the formula
For i = LBound(arrTmp) To UBound(arrTmp)
sAddress = ""
If rngDest.Parent.Name <> arrTmp(i).Parent.Name Then
sAddress = "'" & arrTmp(i).Parent.Name & "'!"
End If
sAddress = sAddress & arrTmp(i).Address(False, False)
sTemplate = Replace(sTemplate, "{" & CStr(i + 1) & "}", sAddress)
Next i
rngDest.Formula = sTemplate 'assign the formula
End Sub

How to Find specific text word using Excel vba

I need to find a specific word from an Excel file. I want to search row by row, and if the word is found, skip 2 rows down and copy the next 20 rows and loop to the next word.
Sub Example4()
Dim FilePath As Workbook
Dim wsheet As Worksheet
Dim i, lcount, lcount2 As Integer
Dim cell, rgFound As Range
Dim Found As Range, LastRow As Long
Set FilePath = Workbooks.Open("D:\SLC.txt")
Dim rowVal As Integer
rowVal = 1
For lcount = 1 To FilePath.Sheets("SLC").Range("A1048576").End(xlUp).Row
Set rgFound = Range("A1:A1048576").Find("TXN. NO TXN SEQ", ThisWorkbook.Sheets(), Cells(rowVal, 1))
FilePath.Cells(wsheet.Range(rowVal).End(xlDown).Row + 3).xlCopy
wbook2.Worksheets(1).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wbook2.SaveAs ("D:\SLC_Copied.xlsx")
wbook2.Close
rowVal = rgFound1.Row
Debug.Print lcount
Next lcount
End Sub
As Siddharth Rout suggested, use Find and FindNext.
Try to choose variable names appropriate to their type, calling a workbook object FilePath is confusing to others trying to understand your script.
Option Explicit
Sub Example4()
Const TEXT = "TXN. NO TXN SEQ"
Const TEXT_FILENAME = "D:\SLC.txt"
Const OUT_FILENAME = "D:\SLC_Copied.xlsx"
Dim wbText As Workbook, wbOut As Workbook, rngOut As Range
Dim wsText As Worksheet, wsOut As Worksheet, count As Integer
Dim rngSearch As Range, rngFound As Range, rowFirstFind As Long
' open text file no link update, read only
Set wbText = Workbooks.Open(TEXT_FILENAME, False, True)
Set wsText = wbText.Sheets(1)
' search
Set rngSearch = wsText.Columns("A:A")
Set rngFound = rngSearch.Find(what:=TEXT, LookIn:=xlValues, LookAt:=xlPart)
If rngFound Is Nothing Then
wbText.Close
MsgBox "No lines match [" & TEXT & "]", vbCritical, "Exiting Sub"
Exit Sub
Else
' create new workbook for results
Set wbOut = Workbooks.Add
Set wsOut = wbOut.Sheets(1)
Set rngOut = wsOut.Range("A1")
rowFirstFind = rngFound.Row
Do
'Debug.Print rngFound.Row
rngFound.Offset(3, 0).Resize(20, 1).Copy rngOut
Set rngOut = rngOut.Offset(20, 0)
Set rngFound = rngSearch.FindNext(rngFound)
count = count + 1
Loop Until rngFound.Row = rowFirstFind
End If
wbText.Close False
wbOut.SaveAs OUT_FILENAME
MsgBox count & " blocks copied to " & wbOut.Name, vbInformation, "Finished"
wbOut.Close
End Sub

VBA Loop through row until blank and variable use

The code below is a web page table scraper that I am using and it works nicely. It currently only opens the hyperlink that is in location 'L4' using .Open "GET", Range("L4"), False
Sub ImportData()
'Objects
Dim htm As Object
Dim Tr As Object
Dim Td As Object
Dim Tab1 As Object
'Create HTMLFile Object
Set HTML_Content = CreateObject("htmlfile")
'Get the WebPage Content to HTMLFile Object
On Error GoTo Error
With CreateObject("msxml2.xmlhttp")
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
.send
HTML_Content.body.innerHTML = .responseText
End With
On Error GoTo Error
'Add New Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "ESTIMATE"
'Set table variables
Column_Num_To_Start = 1
iRow = 2
iCol = Column_Num_To_Start
iTable = 0
'Loop Through Each Table and Download it to Excel in Proper Format
For Each Tab1 In HTML_Content.getElementsByTagName("table")
With HTML_Content.getElementsByTagName("table")(iTable)
For Each Tr In .Rows
For Each Td In Tr.Cells
Sheets(2).Cells(iRow, iCol).Select
Sheets(2).Cells(iRow, iCol) = Td.innerText
iCol = iCol + 1
Next Td
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tr
End With
iTable = iTable + 1
iCol = Column_Num_To_Start
iRow = iRow + 1
Next Tab1
'Success
'Loop to find authorised hours string
Dim rng1 As Range
Dim strSearch As String
strSearch = "Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
'Add Value to Sheet1
Sheets(1).Range("E4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("E4").Value = 0
End If
strSearch = "Actual Hours"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("D4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("D4").Value = 0
'Move on to next
End If
strSearch = "Name"
Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets(1).Range("J4").Value = rng1.Offset(0, 1)
Else
Sheets(1).Range("J4").Value = "NULL"
End If
'Scrape Description
Dim desc As String
HTML_Content.getElementsByTagName ("div")
desc = HTML_Content.getElementsByTagName("p")(0).innerText
Sheets(1).Range("K4").Value = desc
'Keep Sheet 1 Open
Sheets(1).Activate
'Delete ESTIMATE Sheet
Application.DisplayAlerts = False
Sheets(2).Delete
Application.DisplayAlerts = True
Error:
End Sub
The starting row of the hyperlink is L4, how could I make a loop that cycles through all links located in the L column and runs this script for each hyperlink that is in column L? How would I make a variable to so that Range will know what row is currently being processed?
Could I put my code into something like this:
For Each i In Sheet1.Range("L4:L200")
' code here
Next i
Any help is much appreciated, thank you.
change
Sub ImportData()
...
.Open "GET", Range("L4"), False 'Cell that contains hyperlink
...
into
Sub ImportData(urlToOpen as string)
...
.Open "GET", urlToOpen, False 'Cell that contains hyperlink
...
and add a calling procedure:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i)
Next i
end sub
UPDATE 1
To get data from the procedure you might either send it back into the main procedure or you prepare a place prior to calling the procedure:
either:
Sub CallRangeL_Urls
For Each i In Sheet1.Range("L4:L200")
' code here
call ImportData(i, returnValue)
i.offset(0,1).value = returnValue
Next i
end sub
Sub ImportData(urlToOpen as string, returnValue as string)
...
'returnValue = Data you want to give back
returnValue = DataSource...(I didn't read your code again ;-)
...
or:
Sub CallRangeL_Urls
Dim targetRange as Range
For Each i In Sheet1.Range("L4:L200")
' code here
sheets.add after:=sheets(1)
'set a link on the sheet
Range("A1").value = i
Set targetRange = Range("A3")
call ImportData(i, targetRange)
Next i
end sub
Sub ImportData(urlToOpen as string, target as range)
...
'Save whatever data to the new sheet
target.offset(0,0).value = datavalue1 'Range("A3")
target.offset(1,0).value = datavalue1 'Range("A4")
target.offset(2,0).value = datavalue1 'Range("A5")
...
UPDATE 2
UPDATE 2: single data items (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim Sheet1 As Worksheet
Dim returnValue As String
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
' code here
Debug.Print "url: "; iCell.Value
Call ImportData(iCell.Value, returnValue)
iCell.Offset(0, 1).Value = returnValue
Debug.Print returnValue
Next iCell
End Sub
Sub ImportData(urlToOpen As String, ByRef returnValue As String)
'...
'returnValue = Data you want to give back
returnValue = "This is the data we get back from yourUrl: " & urlToOpen & " - DATA/DATA/DATA" 'DataSource...(I didn't read your code again ;-)
End Sub
Immediate window:
url: www.google.de
This is the data we get back from yourUrl: www.google.de - DATA/DATA/DATA
UPDATE 2: data on result sheet(s) (working example)
Option Explicit
Sub CallRangeL_Urls()
Dim iCell As Range
Dim targetRange As Range
Dim Sheet1 As Worksheet
Set Sheet1 = ActiveSheet
For Each iCell In Sheet1.Range("L4:L4")
'create a new "RESULTS" sheets
Sheets.Add after:=Sheets(1)
Debug.Print "New sheet created: " & ActiveSheet.Name
'set a link on the sheet
Range("A1").Value = iCell.Value 'leave a copy of the url on the sheet as a reference
Set targetRange = Range("A3") 'here we want to get the results
Call ImportData(iCell.Value, targetRange)
Next iCell
End Sub
Sub ImportData(urlToOpen As String, target As Range)
Dim datavalue1, datavalue2, datavalue3
'...
datavalue1 = "data value 1"
datavalue2 = "data value 2"
datavalue3 = "data value 3"
'Save whatever data to the new sheet
target.Offset(0, 0).Value = datavalue1 'Range("A3")
target.Offset(1, 0).Value = datavalue2 'Range("A4")
target.Offset(2, 0).Value = datavalue3 'Range("A5")
Debug.Print "datavalues stored on sheet: " & target.Parent.Name
'...
End Sub
Immediate window:
New sheet created: Sheet2
datavalues stored on sheet: Sheet2

Excel VBA Hyperlinking Values Type Mismatch Error

I'm new to VBA and trying to put together a macro to copy in data from another workbook and then hyperlink values on an existing sheet to the sheets i've copied in based on a string value in a cell. For the most part the script works however i'm getting a type mismatch error. Hoping someone can help identify what i'm doing wrong.
Sub CopyTitleDetailData()
'Copy all sheets from Key New Release Detail sheet, overrides existing sheets, copys in new sheets
Dim wb As Workbook, ws As Worksheet, wbTarget As Workbook, wsTarget As Worksheet
Application.ScreenUpdating = False
Set wb = ActiveWorkbook 'Main workbook
Dim pth As String
pth = wb.Path
Dim titleDetailPth As String
titleDetailPth = Left(pth, InStrRev(pth, "\") - 1)
Dim filePthName As String
filePthName = titleDetailPth & "\Files for Pre-Order Report (Macro & Alteryx)\" & "Key New Release Accounts Details.xlsx"
Set wbTarget = Workbooks.Open(filePthName, UpdateLinks = False, ReadOnly = True)
For Each wsTarget In wbTarget.Worksheets 'A loop for each worksheet in the Key New Release Detail workbook
For Each ws In wb.Worksheets 'A loop for each worksheet in the Pre-Order (i.e. active workbook)
If wsTarget.Name = ws.Name Then 'If the sheet I am importing exists, it will be deleted
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
wsTarget.Copy After:=wb.Sheets(wb.Sheets.Count) 'Copies it into the last sheet
wb.Sheets(wsTarget.Name).Visible = 0 'Hides the copied sheets
Next wsTarget
wbTarget.Close SaveChanges:=False
Application.ScreenUpdating = True
'Loops through a specified column and when a specified value is found, puts a hyperlink in the cell below
Const cWsName As String = "Title Detail"
Const cSearch As String = "Title"
Const cRow1 As Integer = 1
Const cRow2 As Integer = 800
Const cCol As String = "D"
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCell1 As Range
Dim rCell2 As Range
Dim iR As Integer
Dim strText As String
Dim strAddr As String
Set oWb = ActiveWorkbook
Set oWs = oWb.Worksheets(cWsName)
For iR = cRow1 To cRow2
Set rCell1 = oWs.Range(cCol & iR)
Set rCell2 = oWs.Range(cCol & iR + 1)
strText = rCell2.Text 'What's written in the cell.
strAddr = rCell2.Address 'The address e.g. B1, B13 ...
If rCell1 = cSearch Then
If strText <> "" Then
'Anchor is the place where i'm placing the hyperlink.
'SubAddress is where the hyperlink will take you
rCell2.Hyperlinks.Add _
Anchor:=rCell2, _
Address:="", _
SubAddress:="'" & rCell2 & "'!" & "A1", _
TextToDisplay:=strText 'The same text that orginally lived in the cell
Else
'What im doing if the cell is empty (i.e. nothing)
End If
End If
Next
Dim beginRow As Long
Dim endRow As Long
Dim chkCol As Long
Dim rowCnt As Long
Dim rngResult As Range
beginRow = 1
endRow = 800
chkCol = 1
With oWs
.Cells.EntireRow.Hidden = False 'Unhides all rows, remove line if that's not desired
For rowCnt = beginRow To endRow
If .Cells(rowCnt, chkCol) = "X" Then
If rngResult Is Nothing Then
Set rngResult = .Cells(rowCnt, 1)
Else
Set rngResult = Union(rngResult, .Cells(rowCnt, 1))
End If
End If
Next rowCnt
End With
If Not rngResult Is Nothing Then rngResult.EntireRow.Hidden = True
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim oWs As Workbook
Dim targetString As String, targetSheet As Worksheet
Set oWs = ActiveWorkbook
targetString = Cells(Target.Range.Row, Target.Range.Column).Value
Set targetSheet = oWs.Sheets(targetString)
If targetSheet.Visible = False Then
targetSheet.Visible = True
End If
'End on Title Detail Sheet
targetSheet.Select
End Sub
Per this documentation, you have to provide an Address when adding a hyperlink. you seem to be setting Address = ""
https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add

VBA match function mismatch despite having the search value in source

Option Explicit
Sub ExtractDivFromAastocks()
Dim StockCode As String, Anchor As String
Dim ws As Worksheet
StockCode = "02800"
Anchor = "Announce Date"
Set ws = ExtractRawDivFromAastocks(StockCode)
Call CleanAastocksDiv(StockCode, ws)
End Sub
Private Function ExtractRawDivFromAastocks(StockCode As String)
Dim WsFound As Boolean
Dim i As Integer
WsFound = False
For i = 1 To Sheets.Count():
If Worksheets(i).Name = StockCode Then
WsFound = True
End If
If WsFound = True Then
Exit For
End If
Next i
If WsFound = True Then
Application.DisplayAlerts = False
Worksheets(StockCode).Delete
Application.DisplayAlerts = True
End If
Dim ws As Worksheet
Dim qt As QueryTable
Dim Website As String, Aastock As String
Aastock = "http://www.aastocks.com/en/stocks/analysis/dividend.aspx?symbol="
Website = Aastock & StockCode
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count()))
ws.Name = StockCode
Set qt = ws.QueryTables.Add( _
Connection:="URL;" & Website, _
Destination:=ws.Range("A1"))
With qt
.RefreshOnFileOpen = True
.Refresh
End With
Set ExtractRawDivFromAastocks = ws
End Function
Private Sub CleanAastocksDiv(StockCode As String, ws As Worksheet)
Dim StartRow As Integer
StartRow = Application.Match("Announce Date", ws.Range("A:A"), 0)
ws.Range("A1:" & _
ws.Cells(StartRow - 1, ws.Columns.Count()).Address).EntireRow.Delete
End Sub
The worksheet indeed has the string value in it, and I have no idea why the match fails. I have tried using the Match function on the sheet itself, it works. Could this be some kind of reference issues? The cell in the sheet doesn't seem to have weird whitespaces. It would be really great if anyone can help me with this:
Public Sub TestMe()
Dim ws As Worksheet: Set ws = Worksheets(1)
Dim StartRow As Variant
StartRow = Application.Match("Announce Date", ws.Range("A:A"), 0)
If IsError(StartRow) Then Exit Sub
If StartRow < 2 Then Exit Sub
ws.Range("A1:A" & StartRow - 1).EntireRow.Delete
End Sub
Declare StartRow as a Variant, because if Announce Date does not exist, it would return an error;
It can be checked with the IsError(StartRow) and exit if it is not the case;
If StartRow < 2 Exit Sub is needed to avoid a possible error if StartRow is 1;

Resources