Teleporpoise
New Member
- Joined
- May 23, 2019
- Messages
- 31
I have 2 VBA codes that are almost identical to each other, the only difference is that one of them has a prompt for message box with input to fill in column B. Basically code 2 is identical to code 1, but with all the columns shifted one down (B-C, C-D, etc). Below is code 1
And here is code 2:
The error highlights this line:
As the problem.
I don't know what's wrong, it works perfectly for the other code. I thought that Application.Match might have been wrong, as it did not return a value at all, only #N/A, but when I put Application.WorksheetFunction.Match or WorksheetFunction.Match, I receive the same error 1004.
Any insights?
Thanks!
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
' if statement to not run code if multiple targets selected
Dim ColumnA As Range
Dim ColumnG As Range
Dim ColumnJ As Range
Dim ColumnM As Range
Dim FRSheet As Worksheet
Dim timestamp As Date
Dim CurrentRow As Integer
Dim FirstCell As String
Dim LastCell As String
Dim allpartstablerange As Range
Dim ifsdesc As Range
Dim partFT As Range
Dim ifscodecolnum As Integer
Dim ftdesccolnum As Integer
Dim allpartstable As ListObject
Set FRSheet = ThisWorkbook.Worksheets("FR")
Set ColumnA = Range("A:A")
Set ColumnG = Range("G:G")
Set ColumnJ = Range("J:J")
Set ColumnM = Range("M:M")
FRSheet.Unprotect
CurrentRow = Target.Row ' Check existance of serial num
' Nothing happens if there is no change in A
' Issue: even when A is deleted this triggers this code
If Not (Application.Intersect(ColumnA, Range(Target.Address)) Is Nothing) Then
'Target.Value2 = ""
If CurrentRow > 4 Then 'This belongs in top protection *OR LOGIC
' Gear Type
FRSheet.Cells(CurrentRow, "B").Value = FRSheet.Cells(3, "B").Value
' Operation#
FRSheet.Cells(CurrentRow, "C").Value = FRSheet.Cells(3, "C").Value
' MachineID
FRSheet.Cells(CurrentRow, "D").Value = FRSheet.Cells(3, "D").Value
' EmployeeID
FRSheet.Cells(CurrentRow, "E").Value = FRSheet.Cells(3, "E").Value
' Time stamp - now
FRSheet.Cells(CurrentRow, "F").Value = Now
End If
' Jump to gear status - GOOD vs MRB
Sheets("FR").Select
CurrentRow = Target.Row
Cells(CurrentRow, "G").Select
End If
' Nothing happens if Column G is left blank
If Not (Application.Intersect(ColumnG, Range(Target.Address)) Is Nothing) Then
' If GOOD
If FRSheet.Cells(CurrentRow, "G").Value = "OK" Then
' Time Stamp
FRSheet.Cells(CurrentRow, "H").Value = Now
'FRSheet.Cells(CurrentRow, "H").NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
' Jump to first column on next row
Sheets("FR").Select
Cells(ActiveCell.Row + 1, "A").Select
' If MRB
ElseIf FRSheet.Cells(CurrentRow, "G").Value = "MRB" Then
' Time Stamp
FRSheet.Cells(CurrentRow, "H").Value = Now
'FRSheet.Cells(CurrentRow, "H").NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
FirstCell = Trim("I" & CurrentRow)
LastCell = Trim("O" & CurrentRow)
' Unlock MRB portion
FRSheet.Unprotect
FRSheet.Range(FirstCell, LastCell).Locked = False
' Combine Gear Type and OP# for lookup menu
Cells(CurrentRow, "I").Value = Cells(3, "B").Value & " - " & Cells(3, "C").Value
' Jump to J
Cells(CurrentRow, "J").Select
' Code to do nothing if J is left blank, only stay at J
End If
End If
If Not (Application.Intersect(ColumnJ, Range(Target.Address)) Is Nothing) Then
'look for MRB flag
'can only run if MRB in cell G
Set allpartstable = ThisWorkbook.Sheets(2).ListObjects("All_Parts")
Set allpartstablerange = allpartstable.Range
Set partFT = allpartstable.ListColumns("Part FT").Range
ftdesccolnum = allpartstable.ListColumns("FT DESC").Index
' Combine Gear Type and Feature# for lookup menu
Cells(CurrentRow, "K").Value = Cells(3, "B").Value & " - " & Cells(CurrentRow, "J").Value
Cells(CurrentRow, "L") = Application.Index(allpartstablerange, Application.Match(FRSheet.Cells(CurrentRow, "K"), partFT, 0), ftdesccolnum)
Cells(CurrentRow, "M").Select
End If
' Code to do nothing if M is empty, only stay at M
If Not (Application.Intersect(ColumnM, Range(Target.Address)) Is Nothing) Then
' Combine Gear Type, OP#, Feature#, and IFS Code to create MRB Code
Set allpartstable = ThisWorkbook.Sheets(2).ListObjects("All_Parts")
Set allpartstablerange = allpartstable.Range
Set ifsdesc = allpartstable.ListColumns("IFS DESC").Range
ifscodecolnum = allpartstable.ListColumns("IFS CODE").Index
Cells(CurrentRow, "N").Value = Application.Index(allpartstablerange, Application.Match(FRSheet.Cells(CurrentRow, "M"), ifsdesc, 0), ifscodecolnum)
Cells(CurrentRow, "O").Value = Cells(CurrentRow, "I").Value & " - " & Cells(CurrentRow, "J").Value & " - " & Cells(CurrentRow, "N").Value
Cells(ActiveCell.Row + 1, "A").Select
End If
' Protect Sheet
FRSheet.Protect
' Jump to first column on next row
Application.EnableEvents = True
End SubAnd here is code 2:
Code:
Option Explicit
Dim ColumnA As Range
Dim ColumnB As Range
Dim ColumnH As Range
Dim ColumnK As Range
Dim ColumnN As Range
Dim FRSheet As Worksheet
Dim timestamp As Date
Dim CurrentRow As Integer
Dim FirstCell As String
Dim LastCell As String
Dim ShaftSN As Long
Dim allpartstablerange As Range
Dim ifsdesc As Range
Dim partFT As Range
Dim ifscodecolnum As Integer
Dim ftdesccolnum As Integer
Dim allpartstable As ListObject
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
' if statement to not run code if multiple targets selected
Set FRSheet = ThisWorkbook.Worksheets("FR")
Set ColumnA = Range("A:A")
Set ColumnB = Range("B:B")
Set ColumnH = Range("H:H")
Set ColumnK = Range("K:K")
Set ColumnN = Range("N:N")
FRSheet.Unprotect
CurrentRow = Target.Row
' Check existance of serial num
' Nothing happens if there is no change in A
' Issue: even when A is deleted this triggers this code
If Not (Application.Intersect(ColumnA, Range(Target.Address)) Is Nothing) Then
'Target.Value2 = ""
ShaftSN = InputBox("Enter Assembly Shaft Serial Number")
FRSheet.Cells(CurrentRow, "B").Value = ShaftSN
If CurrentRow > 4 Then 'This belongs in top protection *OR LOGIC
' Gear Type
FRSheet.Cells(CurrentRow, "C").Value = FRSheet.Cells(3, "C").Value
' Operation#
FRSheet.Cells(CurrentRow, "D").Value = FRSheet.Cells(3, "D").Value
' MachineID
FRSheet.Cells(CurrentRow, "E").Value = FRSheet.Cells(3, "E").Value
' EmployeeID
FRSheet.Cells(CurrentRow, "F").Value = FRSheet.Cells(3, "F").Value
' Time stamp - now
FRSheet.Cells(CurrentRow, "G").Value = Now
End If
' Jump to gear status - GOOD vs MRB
Sheets("FR").Select
CurrentRow = Target.Row
Cells(CurrentRow, "H").Select
End If
' Nothing happens if Column G is left blank
If Not (Application.Intersect(ColumnH, Range(Target.Address)) Is Nothing) Then
' If GOOD
If FRSheet.Cells(CurrentRow, "H").Value = "OK" Then
' Time Stamp
FRSheet.Cells(CurrentRow, "I").Value = Now
'FRSheet.Cells(CurrentRow, "I").NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
' Jump to first column on next row
Sheets("FR").Select
Cells(ActiveCell.Row + 1, "A").Select
' If MRB
ElseIf FRSheet.Cells(CurrentRow, "H").Value = "MRB" Then
' Time Stamp
FRSheet.Cells(CurrentRow, "I").Value = Now
'FRSheet.Cells(CurrentRow, "I").NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
FirstCell = FRSheet.Cells(CurrentRow, "J")
LastCell = FRSheet.Cells(CurrentRow, "P")
' Unlock MRB portion
FRSheet.Unprotect
' Combine Gear Type and OP# for lookup menu
Cells(CurrentRow, "J").Value = Cells(3, "C").Value & " - " & Cells(3, "D").Value
' Jump to J
Cells(CurrentRow, "K").Select
' Code to do nothing if K is left blank, only stay at K
End If
End If
If Not (Application.Intersect(ColumnK, Range(Target.Address)) Is Nothing) Then
'look for MRB flag
'can only run if MRB in cell G
Set allpartstable = ThisWorkbook.Sheets(2).ListObjects("All_Parts")
Set allpartstablerange = allpartstable.Range
Set partFT = allpartstable.ListColumns("Part FT").Range
ftdesccolnum = allpartstable.ListColumns("FT DESC").Index
' Combine Gear Type and Feature# for lookup menu
Cells(CurrentRow, "L").Value = Cells(3, "C").Value & " - " & Cells(CurrentRow, "K").Value
Cells(CurrentRow, "M") = WorksheetFunction.Index(allpartstablerange, WorksheetFunction.Match(FRSheet.Cells(CurrentRow, "L"), partFT, 0), ftdesccolnum)
Cells(CurrentRow, "N").Select
End If
' Code to do nothing if M is empty, only stay at M
If Not (Application.Intersect(ColumnN, Range(Target.Address)) Is Nothing) Then
' Combine Gear Type, OP#, Feature#, and IFS Code to create MRB Code
Set allpartstable = ThisWorkbook.Sheets(2).ListObjects("All_Parts")
Set allpartstablerange = allpartstable.Range
Set ifsdesc = allpartstable.ListColumns("IFS DESC").Range
ifscodecolnum = allpartstable.ListColumns("IFS CODE").Index
Cells(CurrentRow, "O").Value = Application.Index(allpartstablerange, Application.Match(FRSheet.Cells(CurrentRow, "N"), ifsdesc, 0), ifscodecolnum)
Cells(CurrentRow, "P").Value = Cells(CurrentRow, "J").Value & " - " & Cells(CurrentRow, "K").Value & " - " & Cells(CurrentRow, "M").Value
Cells(ActiveCell.Row + 1, "A").Select
End If
' Protect Sheet
FRSheet.Protect
' Jump to first column on next row
Application.EnableEvents = True
End SubThe error highlights this line:
Code:
Cells(CurrentRow, "M") = WorksheetFunction.Index(allpartstablerange, WorksheetFunction.Match(FRSheet.Cells(CurrentRow, "L"), partFT, 0), ftdesccolnum)As the problem.
I don't know what's wrong, it works perfectly for the other code. I thought that Application.Match might have been wrong, as it did not return a value at all, only #N/A, but when I put Application.WorksheetFunction.Match or WorksheetFunction.Match, I receive the same error 1004.
Any insights?
Thanks!
