Sub GetData()
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 lRow As Long, lRowEnd As Long, lCurRow As Long
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 wsInput As Worksheet, wsOutput As Worksheet
Set wsInput = Sheets("Raw Data")
Set wsOutput = Sheets("Dist Need")
vReply = "01-Jan-06,31-Dec-06"
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
ReDim vaData(1 To datRange(1) - datRange(0) + 2, 1 To 1)
iColMax = 1
For lRow = 2 To UBound(vaData, 1)
vaData(lRow, 1) = Format(datRange(0) + lRow - 2, "dd-mmm-yy")
Next lRow
lRowEnd = wsInput.Cells(Rows.Count, "A").End(xlUp).Row
If lRowEnd< 2 Then
MsgBox "No data Input present"
Exit Sub
End If
sngPercentIncrement = WorksheetFunction.Max(lRowEnd * 0.01, 1)
lTarget = 0
For lRow = 2 To lRowEnd
If lRow > lTarget Then
Application.StatusBar = Format(lRow / lRowEnd, "0") & "% complete"
lTarget = lRow + sngPercentIncrement
End If
vaInput = wsInput.Range(Cells(lRow, "A").Address, Cells(lRow, "D").Address).Value
bFound = False
sCurCompany = CStr(vaInput(1, 1))
datCur = 0
On Error Resume Next
datCur = CDate(vaInput(1, 4))
On Error GoTo 0
If datCur >= datRange(0) _
And datCur<= datRange(1) Then
lCurRow = datCur - datRange(0) + 2
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 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
End If
vaData(lCurRow, iColFound) = Val(vaData(lCurRow, iColFound)) + Val(vaInput(1, 3))
End If
Next lRow
Application.StatusBar = "Writing Data"
lRow = UBound(vaData, 1)
iCol = UBound(vaData, 2)
sAdd1 = "A1"
sAdd2 = Cells(lRow, iCol).Address
sFormula = "=sum(RC2" & ":RC[-1])"
With wsOutput
.Cells.ClearContents
.Range(sAdd1, sAdd2).Value = vaData
.Cells(1, iCol + 1).Value = "Total"
.Range(Cells(2, iCol + 1).Address, Cells(lRow, iCol + 1).Address).FormulaR1C1 = sFormula
End With
Application.StatusBar = False
End Sub
