Dim Filesavename As String
Dim WeeklyFN As String
Dim MainFN As String
Dim MFile As String
Dim lrow As Long
Dim sfield As String
Dim cellcol As Long
Dim i As Long
Dim lastrow As Long
Dim rownumber As Long
Dim c As Object
Sub CreateReport()
Application.DisplayAlerts = False
MFile = ActiveWorkbook.Name
Application.ScreenUpdating = False
WeeklyFN = Application.GetOpenFilename(fileFilter:="All files (*.*), *.*", Title:="Leanne - Please open the Encompass Report")
If WeeklyFN = "False" Or WeeklyFN = "" Then
MsgBox "You have not selected a file."
Exit Sub
Else
Workbooks.Open Filename:=WeeklyFN
WeeklyFN = ActiveWorkbook.Name
End If
Worksheets.Add().Name = "Report"
With Sheets("Report")
.UsedRange.ClearContents
.[a1:f1].Value = Array("Processor", "Client Name", "Completed date", "Client Data in", "Client Data out", "Payday")
End With
Set SrcWks = Worksheets("Data")
Set DstWks = Worksheets("Report")
Set SrcRng = SrcWks.Range("B10")
Set DstRng = DstWks.Range("A2")
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTexrtCompare
Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp)
If RngEnd.Row < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcWks.Range(SrcRng, RngEnd)
DstWks.UsedRange.Offset(1, 0).ClearContents
For Each Cell In SrcRng
Key = Trim(Cell)
If Key <> "" Then
Task = Cell.Offset(0, 8).Value
If Not Dict.exists(Key) Then
ReDim Data(0, 5)
Data(0, 0) = Cell.Offset(0, 9).Value ' Processor's name
Data(0, 1) = Cell ' Client
Data(0, 2) = Cell.Offset(0, 13).Value ' Completed Date
GoSub GetDueDate
Dict.Add Key, Data
Else
Data = Dict(Key)
GoSub GetDueDate
Dict(Key) = Data
End If
End If
Next Cell
For Each Key In Dict.Keys
Data = Dict(Key)
DstRng.Resize(1, UBound(Data, 2) + 1).Value = Data
Set DstRng = DstRng.Offset(1, 0)
Next Key
Exit Sub
GetDueDate:
n = 0
' Locate the column the Due Date belongs under.
Task = LCase(Task)
If Task Like "client data *" Then n = 3 ' Column D
If Task Like "draft payroll *" Then n = 4 ' Column E
Data(0, 2) = Cell.Offset(0, 15).Value ' Completed date
'End If
If Task Like "fps and eps *" Then n = 5 ' Column F
If n > 0 Then
Data(0, n) = Cell.Offset(0, 11) ' Due Date
End If
Return
' ************************************* why after this point can I not manipulate the data using the following basic code?
With Sheets("Report")
Rows("1:1").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
Columns("D:D").EntireColumn.AutoFit
Columns("D:D").ColumnWidth = 10
Columns("E:E").EntireColumn.AutoFit
Columns("E:E").ColumnWidth = 9.71
Columns("F:F").EntireColumn.AutoFit
Range("C1:F1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
Columns("C:F").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ActiveWorkbook.Worksheets("Report").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Report").Sort.SortFields.Add Key:=Range("A2:A5000") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Report").Sort.SortFields.Add Key:=Range("D2:D543") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Report").Sort
.SetRange Range("A1:F5000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End With
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$F$543").AutoFilter Field:=1, Criteria1:=Array( _
"Ann Taggart", "Carrie Nugent", "Cathy Killen", "Emma Scott", "Fiona McIntosh", _
"Gary McKernan", "Geoffrey Devlin", "Gerard Graham", "Kara Woodside", _
"Krzysztof Malinowski", "Lesley-Ann Stirling", "Lisa Reilly", "Mark Todd", _
"Maureen Black", "Philip McCrudden", "Sebastian Krus"), Operator:= _
xlFilterValues
Cells.Select
Selection.Copy
Range("A1").Select
End Sub
Bookmarks