My VBA Vlookup code is crashing Excel and takes forever to execute. I need the VBA code and not the formula in the cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Call lookup
End Sub
Sub lookup()
Dim srchres As Variant
Dim srch As Variant
Set sh1 = ThisWorkbook.Sheets("Customer")
Set sh4 = ThisWorkbook.Sheets("Invoice")
On Error Resume Next
srchres = Application.WorksheetFunction.VLookup(sh4.Range("A11:C11"), _
sh1.Range("B2:H99999"), 5, False)
On Error GoTo 0
If (IsEmpty(srchres)) Then
sh4.Range("A12") = CVErr(xlErrNA)
Else
sh4.Range("A12:C12").Value = srchres
End If
On Error Resume Next
srch = Application.WorksheetFunction.VLookup(sh4.Range("A11:C11"), _
sh1.Range("B2:H99999"), 6, False)
On Error GoTo 0
If (IsEmpty(srch)) Then
sh4.Range("A13:C13") = CVErr(xlErrNA)
Else
sh4.Range("A13:C13").Value = srch
End If
End Sub
ThisWorkbook's code for creating a drop-down list
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MySheets As Variant
Dim srchres As Variant
Dim srch As Variant
Set sh1 = ThisWorkbook.Sheets("Customer")
Set sh4 = ThisWorkbook.Sheets("Invoice")
MySheets = Array("sh1", "sh4")
If IsNumeric(Application.match(Sh.Name, MySheets, 0)) Then
If Target.Address = "'sh4'!$A$11" Then
sh4.Range("A2:A9999").Cells(sh4.Range("A2:A9999").Rows.Count + 1, 1) = Target
End If
End If
End Sub
Related
So I have a dynamically created worksheet (generated by clicking a command button on a separate sheet) and I am trying to get a Worksheet_Change event to fire only on a specific range in that worksheet. My code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet
Set sh = ThisWorkbook.ActiveSheet
If Not Intersect(Target, Range("A1:K10")) Is Nothing Then
If sh.Name Like "*SP Temp*" Then
Dim i As Variant, countOfS As Integer
countOfS = 0
For Each i In sh.Range("A1:K10")
If i.Value = "S" Then
countOfS = countOfS + 1
End If
Next i
sh.Range("D12").Value = countOfS
sh.Range("D13").Value = SCount - countOfS
' NOTE: SCount is a global variable set in another Sub
End If
End If
End Sub
The intent is to keep a running count of the number of "S" characters entered into cells in the range A1:K10. I have tried adding in Debug.Print statements after the If Not Intersect... statement, but it doesn't seem to fire, despite the values in the target range being altered. What am I doing wrong?
A Workbook SheetChange: Count and Write
ThisWorkbook Module
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' Invalidate.
If Not Sh.Name Like "*SP Temp*" Then Exit Sub ' wrong worksheet
Dim rg As Range: Set rg = Sh.Range("A1:K10")
If Intersect(rg, Target) Is Nothing Then Exit Sub ' no intersection
' Count.
Dim CountOfS As Long: CountOfS = Application.CountIf(rg, "s")
' Write
' Disable events to not re-trigger the event while writing
' since the same worksheet is being written to.
Application.EnableEvents = False
Sh.Range("D12").Value = CountOfS
Sh.Range("D13").Value = SCount - CountOfS
Application.EnableEvents = True
End Sub
With the use of call statement, I am calling a sub RETURNSEARCHMATCHES that includes UDF FINDCOLLETTEROFNAMEDRANGE(string).
The code where I call the function is below:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Selection.Count = 1 Then
If Not Intersect(Target, Range("SearchField")) Is Nothing Then
Call OSS_macros.RETURNSEARCHMATCHES
End If
End If
Application.EnableEvents = True
End Sub
I was debugging the code inside RETURNSEARCHMATCHES and I found out that the UDF function FINDCOLLETTEROFNAMEDRANGE(string) is not called by the sub (the code is below):
Public Function FINDCOLLETTEROFNAMEDRANGE(range_name As String) As String
Dim cell_range As Range
Set cell_range = Range(range_name)
If cell_range.Address(0, 0) <> "" Then
FINDCOLLETTEROFNAMEDRANGE = Left(cell_range.Address(0, 0), 1)
Else
FINDCOLLETTEROFNAMEDRANGE = "NONE"
End If
End Function
Sub RETURNSEARCHMATCHES()
Dim cw As Worksheet
Dim is_matchLeft_name As String
Dim is_matchLeft_col As String
Dim last_row As String
Set cw = Sheets("4c.Travel Costs (Search)")
last_row = CStr(cw.Cells(cw.Rows.Count, 2).End(xlUp).Row)
Debug.Print "OK"
is_matchLeft_name = "Is_Match_from_left"
is_matchLeft_col = FINDCOLLETTEROFNAMEDRANGE(is_matchLeft_name)
Debug.Print is_matchLeft_col
End Sub
Do you know why it is like this?
Am I supposed to pass this UDF function somewhere in the call statement?
I use a worksheet to help keep track of inventory numbers in a warehouse. I am trying to add a time stamp so I can see when I last edited a cell. I already have some VBA macros and get an ambiguous name error when I try to add the code for the time stamp.
This is the code I already have:
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
x = xDic.Keys
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
Set xDCell = Cells(xCell.Row, 9)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("H:H"))
End If
Label1:
Set xRg = Intersect(Target, Range("G:G"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Value
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub
This is the code I tried to add:
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20180830
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 13
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now()
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now()
End If
Next
End If
End If
End Sub
Instead of:
Private Sub Worksheet_Change(ByVal Target As Range)
'first set of code
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'second set of code
End Sub
which as you've found won't compile, you'd have something like
Private Sub Worksheet_Change(ByVal Target As Range)
FirstHandler Target
SecondHandler Target
End Sub
'next 2 subs have your original code
Private Sub FirstHandler(ByVal Target As Range)
'first set of code
End Sub
Private Sub SecondHandler(ByVal Target As Range)
'second set of code
End Sub
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;
I am developing code which creates a copy of a template spreadsheet whenever text is input into any row within column A. The spreadsheet needs to be named after the text entered.
Currently I have the following code, the problem is that it does not name the new spreadsheet after the text I enter.
The code is as below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Set wsNew = Sheets(Target.Text)
If wsNew Is Nothing Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
End If
'name new sheet code here
End If
End Sub
Like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Set wsNew = Sheets(Target.Text)
If wsNew Is Nothing Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
End If
'name new sheet
Worksheets(Worksheets.Count).Name = Target.Text
End If
End Sub
Edit:
User could empty the cell in A1:A10 which will create new tab called "Template (2)". You should also do check:
If Len(Target.Cells.Text) = 0 Then Exit Sub
I'd suggest something like this to create the sheet based on the template with the desired name - but after testing and cleansing the proposed sheet name first for invalid characters
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
Dim strSht As String
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
On Error Resume Next
Set wsNew = Sheets(Target.Text)
On Error GoTo 0
If wsNew Is Nothing Then
If ValidSheetName(Target.Value) Then
strSht = Target.Value
Else
strSht = CleanSheetName(Target.Value)
End If
End If
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = strSht
End If
End Sub
string cleaning code 1
Function ValidSheetName(strIn As String) As Boolean
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "[\<\>\*\\\/\?|]"
ValidSheetName = Not objRegex.test(strIn)
End Function
string cleaning code 2
Function CleanSheetName(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[\<\>\*\\\/\?|]"
CleanSheetName = .Replace(strIn, "_")
End With
End Function