VBA Code Modifications

Regular Contributor

Hello Community, I have the following code in the attached workbook that I need help with changing based on a recent change to a new version of the workbook.  I have attached the old workbook and the new version so you can visualize the changes.  When run, the VBA opens a workbook called COM Walk Tracker, gathers the data, and then plots the retrieved data into the workbook called Combined COM & PM Log.  What I need the VBA Code to do is the same but to expand its plotting of information, when & if more than one COM or PM have been performed.  In essence, to do what it already does but to a greater degree.  Right now only 1 COM or PM gets plotted but if more than 1 COM or PM was performed with in the same month I need the day of the month plotted in the cell. If you are willing to help me adjust the VBA Code I will certainly communicate more to ensure we are on the same track.   Please see the attached workbooks. The following is the current code:

 

Sub Button1_Click()
Dim COMFile As String
Dim wst As Worksheet
Dim wbs1 As Workbook
Dim wbs2 As Workbook
Dim wss1 As Worksheet
Dim wss2 As Worksheet
Dim r As Long
Dim m As Long
Dim unit As String
Dim unitcol As Range
Dim datecol As Range
Dim subccol As Range
Dim rng As Range
Dim adr As String
Dim yr As Long
Dim dtm As Date
Dim mnth As Long
Dim dy As Long
Dim typ As String
Dim typ1 As String
Dim cel As Range
Dim i As Long
Dim p(1 To 12) As Long
Dim t(1 To 12) As Long
Dim p2(1 To 4) As Long
Dim t2(1 To 4) As Long
Dim p3 As Long
Dim t3 As Long
Dim s As String
Dim a As Single
On Error Resume Next
Set wbs1 = Workbooks("PM Detail Report " & Format(Date, "mm-dd-yyyy") & ".xlsx")
On Error GoTo 0
If wbs1 Is Nothing Then
MsgBox "PM Workbook is not open, Open PM workbook and click 'Update Log' button again.", vbExclamation
Exit Sub
End If
Set wst = ThisWorkbook.Worksheets("PM Log")
yr = wst.Range("AL2").Value
' Change the path as needed
'COMFile = "H:\Private\Compliance\Compliance\" & yr & " Compliance\COM\COM WALK TRACKER " & yr & ".xlsx"
'COMFile = "COM WALK TRACKER " & yr & ".xlsx"
COMFile = "H:\housing\Better Housing\Private\Compliance\Compliance\" & yr & " Compliance\COM\COM WALK TRACKER " & yr & ".xlsx"
On Error Resume Next
Set wbs2 = Workbooks.Open(Filename:=COMFile)
On Error GoTo 0
If wbs2 Is Nothing Then
MsgBox "COM Workbook is not open, Open COM workbook and click 'Update Log' button again.", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
With wst.Range("B13:BU329")
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
.ClearComments
End With
typ = LCase(wst.Range("BD2").Value)
m = wst.Range("A11").End(xlDown).Row
Set wss1 = wbs1.Worksheets("WO Performance Detail")
Set unitcol = wss1.Cells.Find(What:="Unit Code").EntireColumn
Set datecol = wss1.Cells.Find(What:="Completion Date").EntireColumn
Set subccol = wss1.Cells.Find(What:="WO SubCategory").EntireColumn
For r = 12 To m
unit = wst.Range("A" & r).Value
Set rng = unitcol.Find(What:="0" & unit, LookIn:=xlValues, LookAt:=xlPart)
If Not rng Is Nothing Then
adr = rng.Address
Do
dtm = wss1.Cells(rng.Row, datecol.Column).Value
typ1 = LCase(wss1.Cells(rng.Row, subccol.Column).Value)
If Year(dtm) = yr And typ1 = typ Then
mnth = Month(dtm)
dy = Day(dtm)
Set cel = wst.Range("A" & r).Offset(0, 2 * mnth)
If dy > cel.Value Then
cel.Value = dy
End If
End If
Set rng = unitcol.Find(What:="0" & unit, After:=rng, LookIn:=xlValues, LookAt:=xlPart)
If rng Is Nothing Then Exit Do
Loop Until rng.Address = adr
End If
For i = 1 To 12
Set wss2 = wbs2.Worksheets(MonthName(i, True) & " " & yr Mod 100)
Set rng = wss2.Range("A:A").Find(What:=unit, LookIn:=xlValues, LookAt:=xlPart)
If Not rng Is Nothing Then
If IsDate(rng.Offset(0, 2).Value) Then
Set cel = wst.Range("A" & r).Offset(0, 2 * i - 1)
cel.Value = Day(rng.Offset(0, 2).Value)
s = "Inspectors:" & vbCrLf & rng.Offset(0, 8).Value
Select Case UCase(rng.Offset(0, 9).Value)
Case "PASS"
cel.Interior.Color = vbGreen
p(i) = p(i) + 1
p2((i - 1) \ 3 + 1) = p2((i - 1) \ 3 + 1) + 1
p3 = p3 + 1
Case "PASS WC"
cel.Interior.Color = vbCyan
p(i) = p(i) + 1
p2((i - 1) \ 3 + 1) = p2((i - 1) \ 3 + 1) + 1
p3 = p3 + 1
Case "FAIL"
cel.Interior.Color = vbRed
End Select
If rng.Offset(0, 10).Value <> "" Then
s = s & vbCrLf & "Comment:" & vbCrLf & rng.Offset(0, 10).Value
End If
With cel.AddComment(Text:=s).Shape
With .TextFrame
.Characters.Font.Size = 18
.AutoSize = True
End With
If .Width > 300 Then
a = .Width * .Height
.Width = 300
.Height = a / .Width + 20
End If
End With
t(i) = t(i) + 1
t2((i - 1) \ 3 + 1) = t2((i - 1) \ 3 + 1) + 1
t3 = t3 + 1
End If
End If
Next i
Next r
wbs2.Close SaveChanges:=False
If t3 = 0 Then
wst.Range("AA8").Value = "0.00%" & vbLf & "0/0"
Else
wst.Range("AA8").Value = Format(p3 / t3, "0.00%") & vbLf & p3 & "/" & t3
End If
For i = 1 To 4
s = "Q" & i
If t2(i) = 0 Then
s = s & " " & "0.00%"
Else
s = s & " " & Format(p2(i) / t2(i), "0.00%")
End If
s = s & vbLf & " COM Rate: " & p2(i) & "/" & t2(i)
wst.Cells(8, 6 * i - 4).Value = s
Next i
For i = 1 To 12
s = MonthName(i, True)
'If wst.Cells(10, 2 * i).Value <> 0 Then
' s = s & " " & Format(wst.Cells(10, 2 * i + 1).Value / _
' wst.Cells(10, 2 * i).Value, "0.00%")
'End If
' Alternatively
If t(i) = 0 Then
s = s & " " & "0.00%"
Else
s = s & " " & Format(p(i) / t(i), "0.00%")
End If
s = s & vbLf & "COM Rate: " & p(i) & "/" & t(i)
wst.Cells(9, 2 * i).Value = s
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

The numbers plotted into cells B11, C11, D11 and H11, I11, J11 and so on are a product of VBA math. At the moment, I have formulas in some of them to show what is supposed to happen. Please check out the comments along ROW 10 & 11

 

Thank you,

 

1 Reply
I could really use some help with dialing this in. The VBA Code is pretty much in place and I just need someone with the knowledge & skill to adjust the code to fit the current need. Changes were made to the prior version, which worked just fine, that calls for the changes I am asking help for. Would someone please look this over and if there are any questions I am always here ready to assist. I just do not understand VBA Code enough to make the needed code changes. I am asking for some help from one or more of you VBA coders. Please help!