Macro was working and now doesn't

[darin100K]

Can someone please help me sort through this macro and find what is not working? Last night before bed everything was working fine. This morning, it won't! I can't think of any changes that I have made. Here is what I have with the part not working in bold. Please also remember that I'm fairly new to VBA and am in way over my head. I'm sure things are as efficient as they could be. Thank you so much!

Private Sub Add_Click()

Dim wbATS As Workbook
Dim wsChange As Worksheet
Dim wsTable As Worksheet
Dim wsLogin As Worksheet
Dim wsRoster As Worksheet
Dim wsAttendance As Worksheet
Dim wsReport As Worksheet
Dim wsCalc As Worksheet
Set wsCalc = Sheets("Calc")
Set wsReport = Sheets("Report")
Set wsChange = Sheets("Change")
Set wsTable = Sheets("Table")
Set wsLogin = Sheets("Login")
Set wsRoster = Sheets("Roster")
Set wsAttendance = Sheets("Attendance Policy")
Dim Column As Range
Dim EmpID As String
Dim Row As Range
Dim Infrac As String
Application.ScreenUpdating = False

EmpID = wsChange.Range("G6").Value
Infrac = wsChange.Range("G13").Value
Super = wsLogin.Range("H22").Value



'Enters Infraction Date
Col = 1
With wsTable
NextEmptyRow = .Cells(65536, Col).End(xlUp).Row + 1
.Range("A" & NextEmptyRow) = wsChange.Range("K9").Value
End With

wsTable.Activate
Set Column = wsTable.Cells.Find(EmpID)
Set Row = wsTable.Range("A65536").End(xlUp)

Intersect(Column.EntireColumn, Row.EntireRow).Select
ActiveCell.Value = "-" & wsChange.Range("K13").Value

ActiveCell.AddComment
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Text Text:=Infrac & "," & wsChange.Range("K6").Value & "," & Super
ActiveCell.Select

wsTable.Range("A1:HA106").Select
Selection.Sort Key1:=Sheets("Table").Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

wsTable.Range("A1").Select


wsTable.Range("A:A").Copy Destination:=wsCalc.Range("A1")
wsTable.Cells.Find(EmpID).EntireColumn.Copy Destination:=wsCalc.Range("B1")

Col = 1
With wsCalc
NextEmptyRow = .Cells(65536, Col).End(xlUp).Row + 1
.Range("A" & NextEmptyRow) = wsAttendance.Range("DE1").Value
NextEmptyRow = .Cells(65536, Col).End(xlUp).Row + 1
.Range("A" & NextEmptyRow).Offset(-1, 1).Value = wsAttendance.Range("DF1").Value
End With

wsCalc.Activate
wsCalc.Range("A1:B106").Select
Selection.Sort Key1:=Sheets("Calc").Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Dim PointsDate As String
PointsDate = wsAttendance.Range("DE1").Value
Dim lRowMax As Long, lRow As Long
With Worksheets("Calc")
lRowMax = .Range("A" & Rows.Count).End(xlUp).Row
For lRow = lRowMax To 2 Step -1
If .Range("A" & lRow).Value < PointsDate Then .Rows(lRow).Delete
Next
End With




wsChange.Activate
wsChange.Range("A1").Select
wsCalc.Range("D2").Value = "=SUM(B:B)-B1"
wsCalc.Range("C2").Value = "Total Points Remaining"

Dim Total As String
Total = wsCalc.Range("D2").Value
Dim FName As String
FName = wsChange.Range("A100").Value


Select Case Total
Case 16 To 30
MsgBox FName & " has " & Total & " points remaining for the rest of this period. As such, no action is currently needed."
Case 11 To 15
MsgBox FName & " has " & Total & " points remaining for the rest of this period. As such, a verbal written warning needs to be issued."
Case 1 To 10
MsgBox FName & " has " & Total & " points remaining for the rest of this period. As such, a written warning needs to be issued."
Case Else
MsgBox FName & " has " & Total & " points remaining for the rest of this period. As such, please work with Darin to determine if this employee should be terminated."
End Select

Dim myCell As Range
Dim myRng As Range
Dim x

With wsCalc
Set myRng = Nothing
On Error Resume Next
Set myRng = .Range("b:b").Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0


If Not myRng Is Nothing Then
For Each myCell In myRng.Cells
With myCell.Offset(0, 5)
.Value = myCell.Comment.Text
txt = Replace(.Value, Chr(10), "")
x = Split(txt, ",")
x(UBound(x) - 1) = x(UBound(x) - 1) & Chr(32) & x(UBound(x))
.Offset(, 1).Resize(, UBound(x)).Value = x
End With
Next myCell
End If
End With

wsCalc.Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
wsCalc.Columns("G:G").Delete

End Sub

 

[Cbrine]

When you say "not working" are you referring to an error or is it just kinda skipping over what you think should be happening? If it's an error, let us know what the error is.

Cal

 

[darin100K]

I'm sorry I didn't specify. I am not receiving an error, but the code in bold is not happening.

Thanks again.

 

[Cbrine]

This line copies Sheet Tables Column A to sheet Calc Column A.

wsTable.Range("A:A").Copy Destination:=wsCalc.Range("A1")

This line copies the found employees column from Table to Calc column B. I ran a controlled test on the line, and it seems to work as well.

wsTable.Cells.Find(EmpID).EntireColumn.Copy Destination:=wsCalc.Range("B1")

Have you tried adding a break point at the first line and stepped through the code to see what is happening? That would be my next step.

HTH
Cal

 

[darin100K]

Truthfully, I've never tried stepping through any code before. Sounds like a good thought though and I'll look more into how to do that. Any pieces of advice, or is it pretty self explanatory?

 

[Cbrine]

Not to hard at all.

1. Open the VB editor.
2. Find the line you want to add a breakponit to.
3. Click on the gray area to the right of the line of code, and a red dot should appear.

Your code will now stop at this point so you can see what is happening on the workbook at that point(Maybe try a manual search on the search string).
Make sure your debug toolbar is open, so you can cycle through each line with the step into button.
You will also need to use the immediate window. It lets you execute vb code outside of the program. Great for getting varailable values at a point in time.
I would be using
? EmpID
prior to executing the find line to make sure the EmpID is what you are expecting.

HTH
Cal
HTH
Cal