A tempoarary solution just for the Min and Max Dates
Option Explicit
Sub subgen99a()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Sheet1") 'change as necessary
Set ws2 = Sheets("Sheet2") ' "
Dim Min_Date As Date, Max_Date As Date, WkDate As Date
Dim WkName As String
Dim c, d
Dim r As Integer
Dim firstAdd As String
ws2.Range("J2:" & ws2.Columns("J:Q").SpecialCells(11).Address).ClearContents ' clear the color table
WkName = ws2.[B1] ' the name to look for
Min_Date = ws2.[B3]
Max_Date = ws2.[B2]
Set c = ws1.Columns(2).Find(WkName, lookat:=xlWhole) 'search for the name
If Not c Is Nothing Then 'if the name is found
firstAdd = c.Address 'noting the first found cell
Do ' now we're gonna add data to the approiate columns using a Do Loop
Set d = c 'we need to do this b/c we're gonna search for the right color column
Set c = ws2.Rows(1).Find(c.Offset(0, 1).Value) ' look for the column color
If Not c Is Nothing Then
If ((d.Offset(0, -1) >= Min_Date) And (d.Offset(0, -1) <= Max_Date)) Then
r = ws2.Cells(Rows.Count, c.Column).End(3).Row + 1 'The empty row in the color column
ws2.Cells(r, c.Column).Value = d.Offset(0, -1).Value 'the date
ws2.Cells(r, c.Column + 1).Value = d.Offset(0, 2).Value 'the amount
End If
End If
Set c = ws1.Columns(2).Find(WkName, lookat:=xlWhole, after:=d) 'find the next name
Loop While Not c Is Nothing And c.Address <> firstAdd
End If
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks