Option Explicit
Sub GetData()
Const sInputSheet As String = "Raw Data" 'Input data Sheet name
Const sOutputSheet As String = "Dist Need" 'Output Data sheet name
Const sOutputWeekSheet As String = "Dist Need Week" 'Output Data Week sheet name
Const sCompanyNameColumn As String = "A" 'Company name column
Const sSizeColumn As String = "C" 'Value to be totalled column
Const sDateOutColumn As String = "D" 'Date Out COlumn
Dim bValid As Boolean, bFound As Boolean
Dim datRange(0 To 1) As Date, datCur As Date
Dim iPtr As Integer, iCol As Integer, iColMax As Integer, iColFound As Integer
Dim iTotalCol As Integer
Dim lRow As Long, lRowEnd As Long, lCurRow As Long
Dim iCompanyNameColumn As Integer 'Company name column
Dim iSizeColumn As Integer 'Value to be totalled column
Dim iDateOutColumn As Integer 'Date Out COlumn
Dim lTarget As Long
Dim saDates() As String, sErrorMessage As String
Dim sAdd1 As String, sAdd2 As String
Dim sCurCompany As String, sFormula As String
Dim sngPercentIncrement As Single
Dim vReply As Variant, vaData() As Variant, vaInput As Variant
Dim vaWeekData() As Variant, vaCompanyNames() As Variant
Dim wsInput As Worksheet, wsOutput As Worksheet, wsOutputWeek As Worksheet
'-- Set input & output sheets --
Set wsInput = Sheets(sInputSheet)
Set wsOutput = Sheets(sOutputSheet)
Set wsOutputWeek = Sheets(sOutputWeekSheet)
'-- Store columns as integers --
iCompanyNameColumn = Range(sCompanyNameColumn & "1").Column
iSizeColumn = Range(sSizeColumn & "1").Column
iDateOutColumn = Range(sDateOutColumn & "1").Column
'-- Set default date range --
vReply = "01-Jan-06,31-Dec-06"
'-- Get date range. Loop until valid or user abort --
Do
bValid = True
vReply = Application.InputBox(prompt:="Please enter date range seperated by a comma", _
Title:="Enter Dates", _
Default:=vReply)
If vReply = False Then
MsgBox "Macro Abandoned"
Exit Sub
End If
saDates = Split(CStr(vReply), ",")
If UBound(saDates) <> 1 Then
bValid = False
sErrorMessage = "Please enter exactly two dates, seperated by a comma"
End If
If bValid Then
For iPtr = 0 To 1
If IsDate(saDates(iPtr)) Then
datRange(iPtr) = DateValue(saDates(iPtr))
Else
bValid = False
If iPtr = 0 Then
sErrorMessage = "'From' date is invalid"
Else
sErrorMessage = "'To' date is invalid"
End If
End If
Next iPtr
End If
If bValid Then
If datRange(0) >= datRange(1) Then
bValid = False
sErrorMessage = "'From' date must be before 'To' date"
End If
End If
If bValid = False Then MsgBox sErrorMessage
Loop Until bValid
'-- Set up Weekly stats --
ReDim vaWeekData(1 To 2, 1 To 1)
vaWeekData(1, 1) = "Week Number"
vaWeekData(2, 1) = "Week Ending"
lRow = 1
For datCur = datRange(0) + 6 To datRange(1) Step 7
lRow = lRow + 1
ReDim Preserve vaWeekData(1 To 2, 1 To lRow)
vaWeekData(1, lRow) = Int((datCur - datRange(0)) / 7) + 1
vaWeekData(2, lRow) = Format(datCur, "ddd dd-mmm-yy")
Next datCur
vaWeekData = WorksheetFunction.Transpose(vaWeekData)
ReDim vaCompanyNames(1 To 1)
ReDim vaData(1 To datRange(1) - datRange(0) + 2, 1 To 1)
iColMax = 1
vaData(1, 1) = "Date"
'-- Store dates in data array --
For lRow = 2 To UBound(vaData, 1)
vaData(lRow, 1) = Format(datRange(0) + lRow - 2, "dd-mmm-yy")
Next lRow
'-- Check if we've got any input data --
lRowEnd = wsInput.Cells(Rows.Count, sCompanyNameColumn).End(xlUp).Row
If lRowEnd < 2 Then
MsgBox "No data Input present"
Exit Sub
End If
'-- Update %age complete every 1% --
sngPercentIncrement = WorksheetFunction.Max(lRowEnd * 0.01, 1)
lTarget = 0
'-- Main loop: scan thru input & update data array --
For lRow = 2 To lRowEnd
'-- Report %age complete if appropriate
If lRow > lTarget Then
Application.StatusBar = Format(lRow / lRowEnd, "0") & "% complete"
lTarget = lRow + sngPercentIncrement
End If
'-- Get curent row Company name --
vaInput = wsInput.Range(Cells(lRow, 1).Address, _
Cells(lRow, WorksheetFunction.Max(iCompanyNameColumn, _
iSizeColumn, _
iDateOutColumn)).Address).Value
bFound = False
sCurCompany = CStr(vaInput(1, iCompanyNameColumn))
'-- Get current row Date out --
datCur = 0
On Error Resume Next
datCur = CDate(vaInput(1, iDateOutColumn))
On Error GoTo 0
'-- Process data if within date range --
If datCur >= datRange(0) _
And datCur <= datRange(1) Then
'-- Calculate data array row --
lCurRow = datCur - datRange(0) + 2
'-- Find company name in row 1 of data array --
iColFound = 0
For iCol = 2 To iColMax
If LCase$(CStr(vaData(1, iCol))) = LCase$(sCurCompany) Then
iColFound = iCol
Exit For
End If
Next iCol
'-- If company name not found, add another column --
If iColFound = 0 Then
iColMax = iColMax + 1
ReDim Preserve vaData(1 To UBound(vaData, 1), 1 To iColMax)
vaData(1, iColMax) = sCurCompany
iColFound = iColMax
vaData(lCurRow, iColFound) = 0
ReDim Preserve vaCompanyNames(1 To iColMax - 1)
vaCompanyNames(iColMax - 1) = sCurCompany
End If
'-- Store total into array --
vaData(lCurRow, iColFound) = Val(vaData(lCurRow, iColFound)) _
+ Val(vaInput(1, iSizeColumn))
End If
Next lRow
Application.StatusBar = "Writing Data"
lRow = UBound(vaData, 1)
iCol = UBound(vaData, 2)
sAdd1 = "B1"
sAdd2 = Cells(lRow, iCol + 1).Address
sFormula = "=sum(RC3" & ":RC[-1])"
iTotalCol = iCol + 2
With wsOutput
.Cells.ClearContents
'-- Store data --
.Range(sAdd1, sAdd2).Value = vaData
'-- Store week numbers --
.Range("A1").Value = "Week Number"
sFormula = "=INT((RC2-R2C2)/7)+1"
.Range(Cells(2, 1).Address, Cells(lRow, 1).Address).FormulaR1C1 = sFormula
'-- Store totals --
.Cells(1, iTotalCol).Value = "Total"
sFormula = "=sum(RC3" & ":RC[-1])"
.Range(Cells(2, iTotalCol).Address, Cells(lRow, iTotalCol).Address).FormulaR1C1 = sFormula
End With
With wsOutputWeek
.Cells.ClearContents
'-- Store Week numbers & dates --
sAdd1 = "A1"
sAdd2 = "B" & UBound(vaWeekData, 1)
.Range(sAdd1, sAdd2).Value = vaWeekData
iCol = UBound(vaCompanyNames) + 2
lRow = UBound(vaWeekData, 1) + 1
'-- Store company names in week data sheet --
.Range("C1:" & Cells(1, iCol).Address).Value = vaCompanyNames
'-- Store formula in week data sheet --
sFormula = "=SUMIF('" & sOutputSheet & "'!C1:C1,'" & sOutputWeekSheet & "'!RC1,'" & sOutputSheet & "'!C:C)/7"
.Range("C2", Cells(lRow, iCol).Address).FormulaR1C1 = sFormula
'-- Store Totals in week data sheet --
.Cells(1, iCol + 1).Value = "Totals"
sFormula = "=SUM(R[0]C3:R[0]C[-1])"
.Range(Cells(2, iCol + 1).Address, Cells(lRow, iCol + 1).Address).FormulaR1C1 = sFormula
End With
Application.StatusBar = False
End Sub
