I'm trying to write an excel VBA to compare columns of a table with the current date and highlight if true.
Here is an example table:
The code that I'm working on is:
Private Sub Workbook_Open()
Dim tbl As Excel.ListObject 'Table name
Dim lr As Excel.ListRow 'Row index
Dim ws As Excel.Worksheet 'Work sheet
'column names
Dim keepInTouch As Range, invite As Range, present As Range, follow As Range
Set ws = ThisWorkbook.Worksheets(1) 'select work book index 1
Set tbl = ws.ListObjects("ContactList") 'set ContactList to tbl
Set keepInTouch = tbl.ListColumns("Keep in Touch").DataBodyRange 'Select the appropreate header
Set invite = tbl.ListColumns("Invite").DataBodyRange
Set present = tbl.ListColumns("Present").DataBodyRange
Set follow = tbl.ListColumns("Follow").DataBodyRange
'MsgBox tbl
For Each lr In tbl.ListRows
If lr.Range(1, tbl.ListColumns("Keep in Touch").Index).Value <> Date Then
keepInTouch.Interior.ColorIndex = xlNone
keepInTouch.Font.ColorIndex = 1
keepInTouch.Font.Bold = False
'If keepInTouch(1).Value = Date And keepInTouch(1).Value <> "" Then
ElseIf lr.Range(1, tbl.ListColumns("Keep in Touch").Index).Value = Date Then
keepInTouch.Interior.ColorIndex = 3
keepInTouch.Font.ColorIndex = 2
keepInTouch.Font.Bold = True
End If
Next lr
End Sub
Line 19: If keepInTouch.Index = Date And keepInTouch.Index <> "" Then causes
Run time error '438':
Object doesn't support this property or method.
What is the correct way of doing this?
If lr.Range(1, tbl.ListColumns("Keep in Touch").Index).Value = Date Then
For example lr.Range(1, 2) is the second column cell in the ListRow Range
keepInTouchIndex = tbl.ListColumns("Keep in Touch").Index
NameIndex = tbl.ListColumns("Name").Index
For Each lr In tbl.ListRows
With lr.Range.Cells(1, NameIndex)
If lr.Range.Cells(1, keepInTouchIndex).Value <> Date Then
.Interior.ColorIndex = 3
.Font.ColorIndex = 2
.Font.Bold = True
Else
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
.Font.Bold = False
End If
End With
Next lr
Related
I am struggling with the error subscript out of range at the code:
Set wsCondition = wbCondition.Worksheets(2)
This code is run very well on windows but when I try on MacOS the error occurs. I am a newbie to VBA and I completely do not understand why this error occurs.
Thanks in advance for your guys advice.
Option Explicit
Public Sub btn1_Click()
Dim i As Double
Dim N As Double
Dim strKeyWord As String
Dim myCount As Integer
Dim OrderCount As Integer
Dim SubTotal As Range, Country As Range, DisCount As Range, Quantity As Range, ItemName As Range, OrderName As Range, RequiredData As Range
Dim wsOrder As Worksheet
Dim wsResult As Worksheet
Dim wsCondition As Worksheet
Dim wbOrder As Workbook
Dim wbCondition As Workbook
Dim OrderFile As String
Dim ConditionFile As String
'Open Order wb
OrderFile = Application.GetOpenFilename()
Set wbOrder = Workbooks.Open(OrderFile)
Set wsOrder = wbOrder.Worksheets(1)
'Open Condition wb
ConditionFile = Application.GetOpenFilename()
Set wbCondition = Workbooks.Open(ConditionFile)
Set wsCondition = wbCondition.Worksheets(2)
Set wsResult = wbCondition.Worksheets(1)
With wsResult
.Range("A1").Value = "Product code"
.Range("B1").Value = "Order Condition"
.Range("C1").Value = "Order Name"
.Range("D1").Value = "Subtotal"
.Range("E1").Value = "Discount"
.Range("F1").Value = "Quantity"
.Range("G1").Value = "Item Name"
.Range("H1").Value = "Country"
.Range("A1").Characters(1, 12).Font.Bold = True
.Range("B1").Characters(1, 16).Font.Bold = True
.Range("C1").Characters(1, 16).Font.Bold = True
.Range("D1").Characters(1, 12).Font.Bold = True
.Range("E1").Characters(1, 12).Font.Bold = True
.Range("F1").Characters(1, 12).Font.Bold = True
.Range("G1").Characters(1, 12).Font.Bold = True
.Range("H1").Characters(1, 12).Font.Bold = True
.Range("A1").WrapText = True
.Range("B1").WrapText = True
.Range("C1").WrapText = True
.Range("D1").WrapText = True
.Range("E1").WrapText = True
.Range("F1").WrapText = True
.Range("G1").WrapText = True
.Range("H1").WrapText = True
.Range("A1").ColumnWidth = 13
.Range("A1").RowHeight = 17
.Range("B1").ColumnWidth = 12
.Range("B1").RowHeight = 17
.Range("C1").ColumnWidth = 14.5
.Range("C1").RowHeight = 17
.Range("G1").ColumnWidth = 99
.Range("G1").RowHeight = 17
End With
'using the CountA ws function (all non-blanks)
myCount = Application.CountA(wsCondition.Range("A:A"))
For i = 2 To myCount Step 1
strKeyWord = wsCondition.Range("A" & i)
wsOrder.Range("R:R").AutoFilter Field:=1, Criteria1:="=*" & strKeyWord & "*"
If wsOrder.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
Set SubTotal = wsOrder.Range("I2", wsOrder.Range("I" & Rows.Count).End(xlUp))
Set Country = wsOrder.Range("AG2", wsOrder.Range("AG" & Rows.Count).End(xlUp))
Set DisCount = wsOrder.Range("N2", wsOrder.Range("N" & Rows.Count).End(xlUp))
Set Quantity = wsOrder.Range("Q2", wsOrder.Range("Q" & Rows.Count).End(xlUp))
Set OrderName = wsOrder.Range("A2", wsOrder.Range("A" & Rows.Count).End(xlUp))
Set ItemName = wsOrder.Range("R2", wsOrder.Range("R" & Rows.Count).End(xlUp))
Set RequiredData = Union(SubTotal, Country, DisCount, Quantity, OrderName, ItemName)
RequiredData.SpecialCells(xlCellTypeVisible).Copy
OrderCount = wsOrder.Range("A2", wsOrder.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells.Count
With wsResult
If OrderCount >= 2 Then
For N = 1 To OrderCount Step 1
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "Available"
Next N
Else
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "Available"
End If
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).PasteSpecial
End With
Else
With wsResult
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "No Order"
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).Value = "N/A"
.Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "N/A"
.Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = "N/A"
End With
End If
OrderCount = 0
Next i
wbCondition.Sheets("Result").Activate
wsOrder.AutoFilterMode = False
End Sub
This has nothing to do whether this code is running on a Mac or Win environment. You have to check if a second worksheet exists in the file you open. In your case you could add following code
If wbCondition.Worksheets.Count > 1 Then
Set wsCondition = wbCondition.Worksheets(2)
else
' Do sth in order to fix the error or end the sub
end if
If you get a subscript out of range it means you tried to access a worksheet that doesn’t exist. This may happen for the following reasons
The worksheet name given to Worksheets is spelled incorrectly.
The name of the worksheet has changed. The worksheet was deleted.
The index was to large e.g. You used Worksheets(5) but there are only four worksheets
The wrong workbook is being used e.g. Workbooks(“book1.xlsx”).Worksheets(“Sheet1”) instead of Workbooks(“book3.xlsx”).Worksheets(“Sheet1”)
You find this here
I have a macro which copy's the entire Sheet 2 to Sheet 1 based on the headers. But, I would like the code to consider the rows which are highlighted in a specific color.
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim Dest As Range
Dim headerRng As Range
Dim lDestRow As Long
Dim i As Integer
Application.ScreenUpdating = False 'Uncomment after testing
Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D1], [D1].End(xlToRight))
Set headerRng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Set Dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = Dest.row
End If
If AmIYellow(Cell) And Cell.Value <> "" Then '<~ blank check too
Set Dest = Output.Cells(DestCounter, 1)
If Dest.row < lDestRow Then
Set Dest = Cells(lDestRow, Dest.Column)
End If
Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Dest.Select
ActiveSheet.Paste
Else
'c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set Dest = c.Offset(1, 0)
If Dest.row < lDestRow Then
Set Dest = Cells(lDestRow, Dest.Column)
End If
Dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
Application.ScreenUpdating = True
End Sub
I'm using a VBA to copy all the unique values from one sheet to another sheet. My VBA looks like this:
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
dictionary.Add shee.Cells(i, "B").Value, 1
End If
Next
Sheet3.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
End Sub
This takes all the unique values from Sheet 1 column B and moves them to sheet 3 column A. What I'm now trying to add is a function that takes the same rows from column C in sheet 1 and paste them into sheet 3 column B.
Is there an easy way to add this to the existing VBA?
please check this:
Option Explicit
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
dictionary.Add shee.Cells(i, "B").Value, shee.Cells(i, "c").Value
End If
Next
With Sheet3
.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
For i = 1 To dictionary.Count
.Cells(i + 2, 2) = dictionary(Sheet3.Cells(i + 2, 1).Value)
Next
End With
Application.ScreenUpdating = True
End Sub
If you just want one column you can utilise the Item. I prefer to avoid the "On Error" statement - the method below will not error if the same key is used (it will just overwrite).
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
With dictionary
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
If Not (.Exists(shee.Cells(i, "B").Value)) Then
.Item(shee.Cells(i, "B").Value) = shee.Cells(i, "C").Value
End If
End If
Next
Sheet3.Range("A3").Resize(.Count).Value = Application.Transpose(.keys)
Sheet3.Range("B3").Resize(.Count).Value = Application.Transpose(.items)
End With
Application.ScreenUpdating = True
End Sub
A strange question perhaps, but is there an alternative way of opening a workbook, searching for a particular reference in a column, and then pulling the data from a another column in that row using VBA, without using VLookup?
The table I am trying to get data from contains a mixture of numbers, text, dates, and the lookup value is often >13 digits long.
I sort of had something working with VLookup, but it was too inconsistent - every so often it would just break because the data type didn't match. An awful lot of 'type mismatch' or 'ByRef' errors - I'd get one right and then another breaks.
Unfortunately I don't know enough to know what to search to get me in the right direction.
If it helps explain what I'm trying to do, here's my code using VLookup that errors all the time:
Sub getData()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Dim wb As Workbook, src As Workbook
Dim srcRange As Range
Dim InputString
Dim strStatus
Dim strStatusNum
Dim strD1
Dim I As Integer
Set wb = ActiveWorkbook
I = 7
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While wb.ActiveSheet.Cells(I, 1) <> ""
'Makes sure src.Close is called if errors
'On Error Resume Next
InputString = wb.Worksheets("Sheet 1").Cells(I, 1)
strStatus = Application.VLookup(InputString, srcRange, 3, False)
strD1 = Application.VLookup(InputString, srcRange, 4, False)
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = Left(strStatus, 2)
wb.Worksheets("Sheet 1").Cells(I, 4) = strStatusNum
If (strStatusNum <> 3) Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "Not at 03. No Work Order"
ElseIf (strStatusNum = 3) And (strD1 <> "") Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "D1 Received"
wb.Worksheets("Sheet 1").Cells(I, 3) = strD1
Else
wb.Worksheets("Sheet 1").Cells(I, 2) = "No D1"
End If
I = I + 1
Loop
src.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
EDIT: Corrected some syntax.
You can use the Find method of the Range object, in your case of the column. The return value is the first cell (represented as another Range object) with a matching value, unless there is no match at all. Then Nothing is returned.
On the returned (single cell) range you can use the EntireRow method to get a Range that represents all the cells on the row of the found cell. On the returned (row) range you can use the Cells method to select the cell matching the column in the same row, that you want to return (again represented as another Range object).
By the way, a more flexible alternative to VLOOKUP in workbook functions is a combination of INDEX and MATCH.
Untested but compiled:
Sub getData()
Dim src As Workbook
Dim srcRange As Range
Dim strStatus, strStatusNum, strD1
Dim m, rw As Range
Set rw = ActiveSheet.Rows(7)
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While rw.Cells(1).Value <> ""
m = Application.Match(rw.Cells(1), srcRange.Columns(1), 0)
If Not IsError(m) Then 'proceed only if got match
strStatus = srcRange.Cells(m, 3).Value
strD1 = srcRange.Cells(m, 4).Value
strStatusNum = Left(strStatus, 2)
rw.Cells(4).Value = strStatusNum
If strStatusNum <> 3 Then
rw.Cells(2) = "Not at 03. No Work Order"
ElseIf strStatusNum = 3 And strD1 <> "" Then
rw.Cells(2) = "D1 Received"
rw.Cells(3) = strD1
Else
rw.Cells(2) = "No D1"
End If
End If
Set rw = rw.Offset(1, 0)
Loop
src.Close False
End Sub
you may be after this refactoring of your code
Sub getData()
Dim wbRng As Range, cell As Range, f As Range
Dim strStatus, strStatusNum, strD1
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
With ActiveWorkbook.ActiveSheet
Set wbRng = .Range("A7:A" & WorksheetFunction.Max(7, .Cells(.Rows.count, 1).End(xlUp).Row)) '<--| set the range of values to be searched for
If WorksheetFunction.CountA(wbRng) = 0 Then Exit Sub '<--| exit if no values under row 7
Set wbRng = wbRng.SpecialCells(xlCellTypeConstants) '<--| narrow the range of values to be searched for down to not blank values only
End With
With Workbooks.Open("D:\Files\test2.xlsx", True, True).Sheets(1) '<--| open wanted workbook and reference its first sheet
With .Range("A1:A" & .Cells(.Rows.count, "H").End(xlUp).Row) '<--| reference its column A range from row 1 down to column H last not empty cell (this is your former "srcRange")
For Each cell In wbRng.SpecialCells(xlCellTypeConstants) '<--| loop through range of values to be searched for
Set f = .Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| look referenced range for current value to be searched for
If Not f Is Nothing Then '<--| if found
strStatus = f.Offset(, 2).Value
strD1 = f.Offset(, 3).Value
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = val(Left(strStatus, 2)) '<--| use 'Val()' function to convert string "03" to "3"
cell.Offset(, 3) = strStatusNum
Select Case True
Case strStatusNum <> 3
cell.Offset(, 1).Value = "Not at 03. No Work Order"
Case strStatusNum = 3 And (strD1 <> "")
cell.Offset(, 1).Resize(, 2).Value = Array("D1 Received", strD1)
Case Else
cell.Offset(, 1).Value = "No D1"
End Select
End If
Next
End With
.Parent.Close False
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
So it's a bit tricky for me since I started learning this 3 days ago...
I have a table with 4 columns: Station name | Date | Program name | Status
When I insert a new record, it will match older ones - but the date will always be different.
I need a code to add to my code that will allow an automatic search of similar records by : Station Name + Program Name - but only for those in the current month, and delete the old existing record before writing in the new one.
This is my current code connected to a button:
Sub OK()
Application.ScreenUpdating = False
' Check if all data was filled
With Empt
If IsEmpty(Sheet1.Range("D4").Value) = True Then
MsgBox "Please fill all fields"
' ElseIf IsEmpty(Sheet1.Range("E4").Value) = True Then
'MsgBox "Please fill all fields"
ElseIf IsEmpty(Sheet1.Range("F4").Value) = True Then
MsgBox "Please fill all fields"
ElseIf IsEmpty(Sheet1.Range("G4").Value) = True Then
MsgBox "Please fill all fields"
Else
'Insert data to table
Sheet1.Range("E4").Value = Now()
Sheet1.Range("D4:G4").Copy
Sheet1.Range("A10").Rows("1:1").Insert Shift:=xlDown
MsgBox "All data have been copied!"
Sheet1.Range("D4:G4").ClearContents
'Sheet1.Range("E4").Value = "Auto Fill"
End If
End With
'CHANGE COLOR OF CELLS
With colrng
NonEmp = Sheet1.Application.CountA(Range("D10:D100000"))
Set MyPlage = Range("D10:D10" & NonEmp)
For Each Cell In MyPlage
Select Case Cell.Value
Case Is = "Completed"
Cell.Interior.ColorIndex = 43
Case Is = "Waiting"
Cell.Interior.ColorIndex = 3
Case Is = "Uploading"
Cell.Interior.ColorIndex = 6
Case Else
Cell.EntireRow.Interior.ColorIndex = xlNone
End Select
Next
End With
' Save records
Sheet1.Range("A10:E50000").Validation.Delete
ThisWorkbook.Save
End Sub
Can someone help please?
Option Explicit
Public Sub OK()
Dim ws As Worksheet, ur As Range, lr As Long, inc As Range, ref As Range
Set ws = Worksheets("Main")
Set inc = ws.Range("D4:G4") 'Insert Data
Set ref = ws.Range("A9") 'Station
With ws
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
If inputIsValid(.Range("D4,F4,G4")) Then
Application.ScreenUpdating = False
Set ur = .Range(ref, "D" & lr)
removePrev ur, .Range("D4"), .Range("F4")
.Range("E4").Value = Now
inc.Copy
ref.Rows(2).Insert Shift:=xlDown
inc.ClearContents
With ref.Offset(1, 3)
Select Case .Value2
Case "Completed": .Interior.ColorIndex = 43
Case "Waiting": .Interior.ColorIndex = 3
Case "Uploading": .Interior.ColorIndex = 6
End Select
End With
.Range("D4").Activate
ThisWorkbook.Save
Application.ScreenUpdating = True
End If
End With
End Sub
Private Function inputIsValid(ByRef inRng As Range) As Boolean
Dim cel As Range, result As Boolean, invRng As Range
result = True
For Each cel In inRng
If Len(cel) = 0 Then
If invRng Is Nothing Then Set invRng = cel Else Set invRng = Union(invRng, cel)
result = False
End If
Next
If Not result Then
invRng.Interior.Color = vbBlue
MsgBox "Please enter values in blue cell(s)"
invRng.Interior.ColorIndex = xlColorIndexAutomatic
ThisWorkbook.Saved = True
End If
inputIsValid = result
End Function
Private Sub removePrev(ByRef rng As Range, ByVal sn As String, pn As String)
Dim v As Range
With rng
Set v = rng.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
On Error Resume Next
.AutoFilter Field:=1, Criteria1:=sn
If v.SpecialCells(xlCellTypeVisible).Count > 1 Then
.AutoFilter Field:=2, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
If v.SpecialCells(xlCellTypeVisible).Count > 1 Then
.AutoFilter Field:=3, Criteria1:=pn
If .SpecialCells(xlCellTypeVisible).Count > 1 Then
v.SpecialCells(xlCellTypeVisible).Rows.EntireRow.Delete
End If
End If
End If
.AutoFilter
End With
End Sub
It works on the following test file:
.
Note: The last sub (showStatus) can be replaced with 3 Conditional Formatting Rules: