Hi Code was working fine but now i am getting this error message ("THAT COMMAND CANNOT BE USED ON MULTIPLE SELECTIONS"
I have BOLDED and underlined where the error highlights
I dont know why this is happening
I have BOLDED and underlined where the error highlights
I dont know why this is happening
Code:
Sub ExtractUnproductive()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ms As Worksheet
Dim ups As Worksheet
Dim prodSh As Worksheet
Dim wfhSh As Worksheet
Dim idxs As Worksheet
Dim Status As String
Set ms = Sheets("RAW DATA")
Set ups = Sheets("UNPRODUCTIVE")
Set prodSh = Sheets("PRODUCTIVE")
Set wfhSh = Sheets("WF HISTORY")
Set idxs = Sheets("INDEX")
Dim LctdR As Long
Dim LunpR As Long
Dim LwfhR As Long
Dim LprodSh As Long
Dim LidxR As Long
ms.Range("N1").Value = "Status" 'Add values to selected cell
ms.Range("O1").Value = "Code"
ms.Range("P1").Value = "Start"
ms.Range("Q1").Value = "Finish"
ms.Range("R1").Value = "Timing"
ms.Range("T1").Value = "Total AQ's"
ms.Range("V1").Value = "Total Mins"
ms.Range("B1").EntireColumn.Insert 'insert column
ms.Range("B1").Value = "User ID"
ms.Range("H1").EntireColumn.Insert 'insert column
ms.Range("H1").Value = "Time"
LctdR = ms.Range("A" & Rows.Count).End(xlUp).Row
LunpR = ups.Range("A" & Rows.Count).End(xlUp).Row
LwfhR = wfhSh.Range("A" & Rows.Count).End(xlUp).Row
LprodSh = prodSh.Range("A" & Rows.Count).End(xlUp).Row
LidxR = idxs.Range("N" & Rows.Count).End(xlUp).Row
With Sheets("RAW DATA")
With .Range("B2:B" & LctdR) 'enter all userId's by using formula
.Formula = "=Index('INDEX'!$N$4:$N$" & LidxR & ",MATCH('RAW DATA'!C2,'INDEX'!$O$4:$O$" & LidxR & ",0))"
.Value = .Value
End With
With .Range("AA2:AA" & LctdR) ' give me the time only
.Formula = "=Mod(G2,1)"
.Value = .Value
.Copy Destination:=.Parent.Range("H2") 'copy to destination range (have to use parent to copy to range H2)
.Clear 'clear range
End With
With .Range("H2:H" & LctdR)
.NumberFormat = "hh:mm:ss" 'format as hh:mm:ss
.HorizontalAlignment = xlCenter
End With
With .Range("AB2:AB" & LctdR) ' give me date only
.Formula = "=INT(G2)"
.Value = .Value
.Copy Destination:=.Parent.Range("G2")
.Clear
End With
With .Range("G2:G" & LctdR)
.NumberFormat = "DD/MM/YYYY"
.HorizontalAlignment = xlCenter
End With
With .Range("T2:T" & LctdR) 'find out the timings for each AQ and then paste special values
.Formula = "=iferror(Vlookup(L2,AQLookup,3,0),"""")"
.Copy
.PasteSpecial xlPasteValues
.Application.CutCopyMode = False
End With
With .Range("W1") 'enter formula to give the count of visible cells only
.Formula = "=Subtotal(3, A2:A" & LctdR & ")"
End With
With .Range("Y1") 'enter formula to give the sum of visible cells only
.Formula = "=Subtotal(9, T2:T" & LctdR & ")"
End With
End With
Dim rngFiltered2 As Range
With Sheets("WORKFLOW")
.Range("A1:G1").AutoFilter Field:=4, Criteria1:="System Shutdown" 'add filter to sheets workflow range A1:G1
With .AutoFilter.Range 'with the autofilter range
On Error Resume Next 'if there is an error skip it
Set rngFiltered2 = .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) ' give me the selected cells only excluding the headings
On Error GoTo 0 'reset back to 0 to find any more errors
If Not rngFiltered2 Is Nothing Then 'check if anything returned
rngFiltered2.EntireRow.Delete 'delete all the visible cells
End If
End With
.Range("A1:G1").AutoFilter Field:=4 'autofilter to show everything
Dim wfs As Worksheet
Set wfs = Sheets("WORKFLOW")
Dim LwfR As Long
LwfR = wfs.Range("A" & Rows.Count).End(xlUp).Row 'find last row on sheets workflow
With wfs.Range("M2:M" & LwfR) ' give me the time only
.Formula = "=If(C2="""","""",Mod(C2,1))"
.Value = .Value
.Copy Destination:=.Parent.Range("C2") 'copy to destination range (have to use parent to copy to range C2)
.Clear 'clear range
End With
With wfs.Range("C2:C" & LwfR)
.NumberFormat = "hh:mm:ss"
End With
With wfs.Range("E2:E" & LwfR)
.NumberFormat = "hh:mm:ss"
End With
End With
For c = 2 To LctdR
For i = 2 To LwfR
If ms.Cells(c, "B") = wfs.Cells(i, "A") Then 'check to see if agent name could be found
If wfs.Cells(i, "C").Value > ms.Cells(c, "H").Value Then 'check to see where the completed work is
If wfs.Cells(i, "D").Value = "Logon" Then 'if its in logon time then fill in the values below
ms.Cells(c, "P").Value = "Unproductive"
ms.Cells(c, "Q").Value = "Logon"
ms.Cells(c, "R").Value = wfs.Cells(i, "C").Value
ms.Cells(c, "R").NumberFormat = "hh:mm:ss"
ms.Cells(c, "S").Value = wfs.Cells(i + 1, "C").Value
ms.Cells(c, "S").NumberFormat = "hh:mm:ss"
Else
Status = wfs.Cells(i - 1, "D").Value 'if any work completed is in a code that is not below then fill in details
If Status <> "Yellow Task" And Status <> "Pink Task" And Status <> "Green Task" And Status <> "Purple Task" And Status <> "Other" Then
ms.Cells(c, "P").Value = "Unproductive"
ms.Cells(c, "Q").Value = Status
ms.Cells(c, "R").Value = wfs.Cells(i - 1, "C").Value
ms.Cells(c, "R").NumberFormat = "hh:mm:ss" 'format as hh:mm:ss
ms.Cells(c, "S").Value = wfs.Cells(i, "C").Value
ms.Cells(c, "S").NumberFormat = "hh:mm:ss"
End If
End If
Exit For
End If
End If
Next i
Next c
Dim rngFiltered As Range
With Sheets("RAW DATA") 'work with sheets raw data
.Range("A1:T1").AutoFilter Field:=16, Criteria1:="Unproductive" 'autofilter to find the word unproductive
With .AutoFilter.Range
On Error Resume Next
Set rngFiltered = .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngFiltered Is Nothing Then 'check if anything returned
ups.Range("A:B,E:F,I:I,N:N").EntireColumn.Hidden = False 'unhide columns
[B][U] rngFiltered.EntireRow.Copy 'copy visible cells
ups.Range("A" & LunpR).Offset(1, 0).PasteSpecial ' paste to unproductive sheet last used row + 1 (blank row)
rngFiltered.EntireRow.Delete 'delete the unproductive [/U][/B]
End If
End With
.Range("A1:T1").AutoFilter Field:=16 'show all data
' copy to productive sheet
prodSh.Range("A:A,E:F,N:N,P:S").EntireColumn.Hidden = False
With .Range("A2:T" & LctdR)
.Copy 'copy
prodSh.Range("A" & LprodSh).Offset(1, 0).PasteSpecial
End With
End With
With Sheets("WORKFLOW")
With .Range("A2:G" & LwfR)
.Copy 'copy
wfhSh.Range("A" & LwfhR).Offset(1, 0).PasteSpecial
End With
End With
Application.Calculation = xlCalculationAutomatic 'turn on automatic calculations
Application.ScreenUpdating = True 'turn on screenupdating
End Sub
