Changing value of a cell based on the value of two cells - VBA Excel - vba

I am trying to add some automation to a spreadsheet by changing the value of cells in one column based on the value in that column and one other. I have got the code below so far. If I use .text the code runs through fine but makes no changes to the values of the cells. If I use .value I get this error message:
Run-time error '13: Type mismatch
Please could someone advise on what I am doing wrong here.
Sub change_orrtime_4()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'For Each employee In Range("Timesheet_RawData[Employee]")
Dim employee As Range
Dim datefield As Range
Dim tbl As ListObject
Dim tRows As Long
Dim tCols As Long
Dim i As Long
Set tbl = Sheets("Timesheet Data").ListObjects("Timesheet_RawData")
With tbl.DataBodyRange
tRows = .Rows.Count
' tCols = .Colummns.Count
End With
With Sheets("Timesheet Data")
Set employee = Sheets("Timesheet Data").Range("Timesheet_RawData[Employee]")
Set datefield = Sheets("Timesheet Data").Range("Timesheet_RawData[Date]")
End With
With Sheets("Timesheet Data")
For i = 2 To tRows
If employee.Value = "Some Name" And datefield.Value = "1" Then ' type mismatch doesnt occur with .text but then nothing works
employee.Value = "Some Name_SomeTeam"
End If
Next i
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

you're setting employee (and datefield, too) to multiple cells ranges, therefore you can't access it Value property, while you can access it Text property that would return a text if all cells share that same text or otherwise a Null
so you have to point at the specific cell in that range, like:
employee(i).Value
finally you could refactor your code a little as follows:
Sub change_orrtime_4()
Dim employee As Range
Dim datefield As Range
Dim tRows As Long
Dim tCols As Long
Dim i As Long
With Sheets("Timesheet Data")
With .ListObjects("Timesheet_RawData")
With .DataBodyRange
tRows = .Rows.Count
' tCols = .Colummns.Count
End With
Set employee = .ListColumns("Employee").DataBodyRange
Set datefield = .ListColumns("Date").DataBodyRange
End With
For i = 1 To tRows
If employee(i).Value = "Some Name" And datefield(i).Value = "1" Then employee(i).Value = "Some Name_SomeTeam"
Next i
End With
End Sub

Related

Apply the Hidden behavior on the whole row

I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub

Type Mismatch Error in Excel

I am using VLookUp functionality in VBA.
And getting error while records are returned from VLookup.
Values in excel is alphanumeric
Below is my code---
Sub SKUMISMATCH()
Dim Wms_Row As Variant
Dim Wms_Col As Variant
Table1 = Sheet1.Range("A2:A243293")
Table2 = Sheet1.Range("J2:K295445")
Wms_Row = Sheet1.Range("G2").Row
Wms_Col = Sheet1.Range("G2").Column
For Each c1 In Table1
Sheet1.Cells(Wms_Row, Wms_Col) = Application.WorksheetFunction.VLookup(c1, Table2, 2, False)
Wms_Row = Wms_Row + 1
Next c1
MsgBox "VLookup Complete"
End Sub
Try the following. You might want to look at ways of further optimizing to make code run faster.
Option Explicit 'Always use
Public Sub SKUMISMATCH()
Application.ScreenUpdating = False 'optimise code
Application.Calculation = xlCalculationManual
Dim Wms_Row As Long 'Declare with expected type not variant
Dim ws As Worksheet
Const Wms_Col As Long = 7 'declare as constant as doesn't change value
Wms_Row = 2
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Table1 As Range 'Declare all variables
Dim Table2 As Range
Dim c1 As Range
With ws 'use With statement to speed up code
Set Table1 = .Range("A2:A243293") 'set range variables
Set Table2 = .Range("J2:K295445")
Table1.Offset(, 6).ClearContents 'Clear lookup return area in case changes to lookup range alters where errors may occur.
For Each c1 In Table1
On Error Resume Next 'skip non matches
.Cells(Wms_Row, Wms_Col) = Application.WorksheetFunction.VLookup(c1, Table2, 2, False)
On Error GoTo 0
Wms_Row = Wms_Row + 1
Next c1
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
MsgBox "VLookup Complete"
End Sub

Finding a date (dimmed as string) in entire workbook

I want to search all worksheets for a date, and when found replace the date by "yes".
I have the code below:
Sub Aftekenen()
Dim Sh As Worksheet
Dim Loc As Range
Dim Datum As String
Datum = "28-12-2015"
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:=Datum)
If Not Loc Is Nothing Then
Do Until Loc Is Nothing
Loc.Value = "Yes"
Set Loc = .FindNext(Loc)
Loop
End If
End With
Set Loc = Nothing
Next
End Sub
However the code runs, however it never reaches the For each loop. When I remove the "-" so the date will become a number it finds it. However when the dashes are present the code does not find any fitting value, however these are present.
try this, for each ... next method with comparing .Text (not value, because of value of the cell for "28-12-2015" is 42366), it works well but some users have an objection to this method by some reasons, as for me less coding better reading
Sub Aftekenen()
Dim Sh As Worksheet, Loc As Range, Datum As String
Application.ScreenUpdating = 0
Datum = "28-12-2015"
For Each Sh In ThisWorkbook.Worksheets
For Each Loc In Sh.UsedRange
If Loc.Text = Datum Then Loc.Value = "Yes"
Next Loc
Next Sh
Application.ScreenUpdating = 1
End Sub
update
if you prefer .find method then for searching of the dates is required to switch Application.FindFormat.NumberFormat to format of the cells with dates, due to the date in .text is 18-05-2015, but .value is 42142
below is your updated variant
Sub Aftekenen()
Dim Sh As Worksheet
Dim Loc As Range
Dim Datum As String
Application.FindFormat.NumberFormat = "dd-mm-yyyy"
Datum = "28-12-2015"
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(Datum, , xlValues, , , , True, , True)
If Not Loc Is Nothing Then
Do Until Loc Is Nothing
Loc.Value = "Yes"
Set Loc = .FindNext(Loc)
Loop
End If
End With
Set Loc = Nothing
Next

Cannot use named range when it is empty

I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!

method range of object _worksheet failed named range

Private Sub Submit_Click()
Application.ScreenUpdating = False
Dim rangeForCode As range, rngLookupRange As range
Dim row As Integer, stock As Integer
Dim result As Integer
Dim drugCodePC As Integer
Dim qty As Integer
Dim ws As Worksheet
drugCodePC = CInt(DrugCode2.Value)
qty = CInt(Quantity.Value)
'Populating the drug name
Set ws = Worksheets("Drug Record")
ws.Select
*Set rangeForCode = ws.range("DrugCodeInventory")*
row = Application.WorksheetFunction.Match(drugCodePC, rangeForCode, 1)
Set rngLookupRange = ws.range("Inventory")
stock = Application.WorksheetFunction.VLookup(drugCodePC, rngLookupRange, 3, False)
result = stock + qty
'MsgBox (row)
ws.Cells(row + 1, 3).Value = result
Application.ScreenUpdating = True
Unload PurchaseForm
End Sub
This keeps throwing the error "method range of object _worksheet failed named range".
The error occurs at the **. I know it has something to do with the named ranged because previously, when i wrote the range of cells ie. "A1:A215" it works. I've checked the name range and it looks right. The name of the named ranged is also correct. I've tried to activate the workbook first but the error is still thrown.
The named ranged is:
= OFFSET(DrugCodeInventory!$A$2, 0, 0, COUNTA(DrugCodeInventory!$A:$A)-1,1)
I only want to select the first column in my worksheet dynamically.
If you run this in the Immediate window does it work?
application.Goto Worksheets("Drug Record").range("DrugCodeInventory")
If it doesn't run then try deleting the named range and creating a new one.
Please also try explicitly qualifying this section of your code:
Dim ws As Excel.Worksheet '<added full qualification here
drugCodePC = CInt(DrugCode2.Value)
qty = CInt(Quantity.Value)
'Populating the drug name
Set ws = Excel.thisworkbook.Worksheets("Drug Record") '<added full qualification here
ws.Select
*Set rangeForCode = ws.range("DrugCodeInventory")*
Kindly use the below isNameRngExist function which will return true when the name range "DrugCodeInventory" exist and then you can proceed with further manipulation.
Function isNameRngExist(myRng As String) As Boolean
On Error Resume Next
isNameRngExist = Len(ThisWorkbook.Names(TheName).Name) <> 0
End Function