Option Base 1
Sub PrepareIOFile()
'Step 1: Open Final SPQ for eDPSS and find the earliest start date
Dim rowCount As Integer
Dim LastRow As Integer
i = 2
Do Until IsEmpty(Cells(i, 1).Value)
i = i + 1
Loop
LastRow = i - 1
rowCount = i - 2
'Step 2: Find the earliest start date in the records
Dim EarliestDate As Date
Dim FirstDate As Date
EarliestDate = CDate(Application.Min(Range("K2:K" & LastRow)))
FirstDate = EarliestDate
'Step 3: Find the number of months between earliest start date and specified month
Dim NowMonth As Integer
Dim NowYear As Integer
NowMonth = InputBox("Please specify the most recent month to compute." & vbNewLine & "Note: Month should be between 1 and 12 only.")
If NowMonth < 1 Or NowMonth > 12 Then
MsgBox "You have entered an invalid month."
Exit Sub
Else
NowMonth = NowMonth
NowYear = InputBox("Please specify the current year to compute." & vbNewLine & "Note: The year should be entered in the yyyy format.")
If NowYear < 2008 Or NowYear > Year(Date) Then
MsgBox "The valid year should be between Year 2008 and Year " & Year(Date) & "."
Exit Sub
Else
NowMonth = NowMonth
NowYear = NowYear
End If
End If
Dim NowDate As Date
Dim MonthRange As Integer
NowDate = CDate("1/" & NowMonth & "/" & NowYear)
EarliestDate = CDate("1/" & Month(FirstDate) & "/" & Year(FirstDate))
MonthRange = Round((NowDate - EarliestDate) / 30.4)
'Step 4: Prepare the output file
Dim MyPath As String
MyPath = ActiveWorkbook.Path & "\output.xls"
Set NewBook = Workbooks.Add
ActiveWorkbook.SaveAs MyPath
Worksheets("Sheet1").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "Basic Price"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Contract No"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Project Title"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Contract Start"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Contract End"
Range("F1").Select
ActiveCell.FormulaR1C1 = "ASPQ"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Qty Delivered"
Range("G2").Select
ActiveCell.FormulaR1C1 = "Cumulative TD"
Range("H2").Select
Dim StartMonth As String
StartMonth = Month(EarliestDate) & "/1/" & Year(EarliestDate)
ActiveCell.FormulaR1C1 = StartMonth
Selection.NumberFormat = "mmmyy"
Dim CurrentMonth As String
For i = 1 To MonthRange
CurrentMonth = Month(CDate(DateAdd("m", 1, EarliestDate))) & "/1/" & Year(CDate(DateAdd("m", 1, EarliestDate)))
Cells(2, 8 + i).Value = CurrentMonth
Cells(2, 8 + i).NumberFormat = "mmmyy"
EarliestDate = DateAdd("m", 1, EarliestDate)
Next i
ActiveWorkbook.Close
'Capture Contract no. and its accompanying information
Dim OutputPath As String
OutputPath = ActiveWorkbook.Path & "\output.xls"
Dim ContractNo As String
Dim ProjectTitle As String
Dim ContractStart As String
Dim ContractEnd As String
Dim ASPQ As Double
j = 1
For j = 1 To LastRow
ContractNo = Cells(j + 1, 1).Value
ProjectTitle = Cells(j + 1, 2).Value
ContractStart = Cells(j + 1, 11).Value
ContractEnd = Cells(j + 1, 12).Value
ASPQ = Cells(j + 1, 14).Value
'Paste these information into the output file
Application.Workbooks.Open (OutputPath)
Cells(j + 2, 2).Value = ContractNo
Cells(j + 2, 3).Value = ProjectTitle
Cells(j + 2, 4).Value = ContractStart
Cells(j + 2, 5).Value = ContractEnd
Cells(j + 2, 6).Value = ASPQ
ActiveWorkbook.Close SaveChanges:=True
'Loop through the bill summaries month by month
'If can find, put the quantity delivered for that month
'If cannot find, set the quantity to zero
Dim MonthTag As Integer
Dim YearTag As Integer
Dim ActiveMonth As String
For m = 1 To MonthRange
Application.Workbooks.Open (OutputPath)
MonthTag = Month(Cells(2, 7 + m).Value)
YearTag = Year(Cells(2, 7 + m).Value)
Select Case MonthTag
Case "1"
ActiveMonth = "JAN" & Right(YearTag, 2)
Case "2"
ActiveMonth = "FEB" & Right(YearTag, 2)
Case "3"
ActiveMonth = "MAR" & Right(YearTag, 2)
Case "4"
ActiveMonth = "APR" & Right(YearTag, 2)
Case "5"
ActiveMonth = "MAY" & Right(YearTag, 2)
Case "6"
ActiveMonth = "JUN" & Right(YearTag, 2)
Case "7"
ActiveMonth = "JUL" & Right(YearTag, 2)
Case "8"
ActiveMonth = "AUG" & Right(YearTag, 2)
Case "9"
ActiveMonth = "SEP" & Right(YearTag, 2)
Case "10"
ActiveMonth = "OCT" & Right(YearTag, 2)
Case "11"
ActiveMonth = "NOV" & Right(YearTag, 2)
Case "12"
ActiveMonth = "DEC" & Right(YearTag, 2)
End Select
ActiveWorkbook.Close SaveChanges:=True
Dim MyFolder As String
Dim Qty As Double
Dim SumQty As Double
Dim Found As Integer
Dim SumFound As Integer
MyFolder = ActiveWorkbook.Path & "\bill\"
If Dir((MyFolder & "\" & YearTag & "\Bill_Summary_Report_" & ActiveMonth & ".xls")) <> "" Then
Application.Workbooks.Open (MyFolder & "\" & YearTag & "\Bill_Summary_Report_" & ActiveMonth & ".xls")
Worksheets("Cement").Select
'Find contract coordinates
x = 1
Do Until Cells(x, 1).Value = "Sno"
x = x + 1
Loop
y = 1
Do Until Cells(x, y).Value = "Contract"
y = y + 1
Loop
'Find Qty coordinates
p = 1
Do Until Cells(p, 1).Value = "Product"
p = p + 1
Loop
q = 1
Do Until Cells(p, q).Value = "C Qty"
q = q + 1
Loop
'Determine the quantity delivered for the month
'this area is proned with problems since one spacing could distort the data
'may want to manual check for multiple occurences of contract no!
n = 1
SumFound = 0
SumQty = 0
Do Until IsEmpty(Cells(17 + n, y).Value)
If ContractNo = Cells(17 + n, y).Value Then
Found = 1
Qty = Cells(19 + n, q).Value
Else
Found = 0
Qty = 0
End If
SumFound = SumFound + Found
SumQty = SumQty + Qty
n = n + 10
Loop
ActiveWorkbook.Close
Else
SumQty = 0
End If
Application.Workbooks.Open (OutputPath)
Cells(j + 2, 7 + m).Value = SumQty
ActiveWorkbook.Close SaveChanges:=True
'MsgBox "m: " & m & vbNewLine & "yr: " & YearTag & vbNewLine & "j: " & j
Next m
Next j
End Sub
问问题
314 次