Sub prodOTD()
Dim db1 As DAO.Database
Dim db2 As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim nme As Name
Dim lastRow As Long
Dim lastCol As Long
Dim strSQL1 As String
Dim strSQL2 As String
Dim linkpath As String
Dim path As String
'create links
path = Workbooks("otd3.xls").path & "\otd3.xls"
linkpath = Workbooks("lead times.xls").path & "\lead times.xls"
'delete existing named ranges
For Each nme In Workbooks("otd3.xls").Names
nme.Delete
Next nme
'set ws to sheet1
Set ws = Workbooks("OTD3.xls").Worksheets("Sheet1")
'create named range for use with sql
Call CreateNamedRange("NamRange", ws)
'create db object
Set db1 = DAO.OpenDatabase(path, False, False, "Excel 8.0")
'create sql string
strSQL1 = "SELECT Item, [Pick Date], sum(qty) AS [Qty Total], [W/O CT Date], Format([Pick Date], 'mmm-yyyy') as PickMonth " & _
"From NamRange " & _
"Group by Item,[Pick Date], [W/O CT Date], Format([Pick Date], 'mmm-yyyy')"
'create recordset using sql string
Set rs1 = db1.OpenRecordset(strSQL1)
'add new worksheet
Set ws1 = Workbooks("OTD3.xls").Worksheets.Add
'paste recordset into new worksheet
ws1.Range("A2").CopyFromRecordset rs1
'copy field names across
For i = 0 To rs1.Fields.Count - 1
ws1.Cells(1, i + 1) = rs1.Fields(i).Name
Next i
'rs1 no longer needed so get rid of it
Set rs1 = Nothing
'add correct formating
ws1.Columns("B:C").NumberFormat = "dd/mm/yyyy"
'create a named range
Call CreateNamedRange("NamRange1", ws1)
'recreate db object to pick up new named range
Set db1 = Nothing
Set db1 = DAO.OpenDatabase(path, False, False, "Excel 8.0")
'create two new sql string
'first one gets all data
strSQL1 = "SELECT PickMonth, Item, sum([Qty Total]) as [QtyTotal] From NamRange1 GROUP BY PickMonth, Item"
'second one gets the ontime data
strSQL2 = "SELECT PickMonth, Item, sum([Qty Total]) as [QtyTotal] From NamRange1 WHERE [W/O CT Date] <= [Pick Date] GROUP BY PickMonth, Item"
'add new worksheet for the data
Set ws2 = Workbooks("OTD3.xls").Worksheets.Add
'create the recordsets
Set rs1 = db1.OpenRecordset(strSQL1)
Set rs2 = db1.OpenRecordset(strSQL2)
'paste the date from the recordset to the new worksheet
ws2.Range("A2").CopyFromRecordset rs1
ws2.Range("G2").CopyFromRecordset rs2
'create loop to look at each product in column G
For i = 2 To ws2.Range("G65536").End(xlUp).Row
'set range for search
With ws2.Range("A1:A" & ws2.Range("A65536").End(xlUp).Row)
'set parameters what to find
Set c = .Find(what:=ws2.Range("G" & i).Value, LookIn:=xlValues, after:=ws2.Range("A1"))
'check for value not being found
If Not c Is Nothing Then
'not needed
'FirstAddress = c.Address
'continue to search until both month and product ID match
Do Until c.Offset(0, 1).Value = ws2.Range("G" & i).Offset(0, 1).Value
'find next month match if product doesn't match
Set c = .FindNext(c)
Loop
End If
'copy ontime deliveries across
c.Offset(0, 3).Value = ws2.Range("G" & i).Offset(0, 2).Value
End With
Next i
ws2.Range("G2").CurrentRegion.Delete
'loop for calculating % on time
For i = 2 To ws2.Range("A65536").End(xlUp).Row
'if number of on time deliveries is empty then add 0
If IsEmpty(ws2.Range("D" & i)) Then
ws2.Range("D" & i).Value = 0
End If
'calculate percentage ontime
ws2.Range("E" & i).Value = ws2.Range("D" & i).Value * 100 / ws2.Range("C" & i).Value
Next i
'delete columns
ws2.Columns("C:D").Delete
'add column titles
ws2.Range("A1").Value = "Monthh"
ws2.Range("B1").Value = "Product"
ws2.Range("C1").Value = "Percent OT"
'set db to nothing so it can be refreshed
Set rs1 = Nothing
'Set db1 = Nothing
ws2.Range("A1:C1").Font.Bold = True
For i = 2 To ws2.Range("A65536").End(xlUp).Row
ws2.Range("A" & i).Value = CDate(ws2.Range("A" & i).Value)
Next i
'create named range for data
Call CreateNamedRange("NamRange2", ws2)
'create new db object
Set db1 = Nothing
Set db1 = DAO.OpenDatabase(path, False, False, "Excel 8.0")
For Each tbl In db1.TableDefs
Debug.Print tbl.Name
Next tbl
Workbooks("otd3.xls").Save
For Each nme In Workbooks("otd3.xls").Names
Debug.Print nme.Name
Next nme
db1.TableDefs.Refresh
For Each tbl In db1.TableDefs
Debug.Print tbl.Name
Next tbl
strSQL1 = "SELECT * FROM NamRange2"
'strSQL1 = "TRANSFORM First([Percent OT]) AS [FirstOfPercent OT] " & _
"SELECT [Product] " & _
"FROM namRange2 " & _
"GROUP BY [Product] " & _
"ORDER BY cdate(Monthh) " & _
"PIVOT cdate(Monthh);"
Set rs1 = db1.OpenRecordset(strSQL1)
ws2.Range("G2").CopyFromRecordset rs1
End Sub
