I think I met all requirements



Sub GetMonthlyData()

DataSheets = Array("Sheet1", "Sheet2")

PromptStr = "Enter Date or nothing to copy all dates"
Do
MyDate = InputBox(Title:="get Date", _
Prompt:=PromptStr)
If MyDate = "" Then
CopyAll = True
Exit Do
Else
If IsDate(MyDate) Then
MyDate = DateValue(MyDate)

For Each Sht In DataSheets
With Sheets(Sht)
FirstDate = .Range("C1")
LastDate = .Range("N1")
If MyDate = FirstDate And _
MyDate <= LastDate Then
CopyAll = False
SourceSht = Sht
Exit Do
End If
End With
Next Sht
End If
End If

PromptStr = "Invalid Date" & vbCrLf & _
"Enter Date or nothing to copy all dates"

Loop While 1 'loop forever

With Sheets("Sheet3")
'format column C for correct month format
.Columns("C").NumberFormat = "mmm-yy"

.Columns("D").NumberFormat = "0,000"

If CopyAll = True Then
'erase all data
LastRowSht3 = .Range("A" & Rows.Count).End(xlUp).Row
If LastRowSht3 < 1 Then
.Rows("2:" & LastRowSht3).Delete
End If
NewRow = 2
Else
LastRowSht3 = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
End If
End With

If CopyAll = True Then
For Each Sht In DataSheets
With Sheets(Sht)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
Name = .Range("A" & RowCount)
PayCAT = .Range("B" & RowCount)
MyDate = .Range("C" & RowCount)

For ColCount = 3 To 14
Amount = .Cells(RowCount, ColCount)
If Amount < 0 Then

With Sheets("Sheet3")
.Range("A" & NewRow) = Name
.Range("B" & NewRow) = PayCAT
.Range("C" & NewRow) = MyDate
.Range("D" & NewRow) = Amount
NewRow = NewRow + 1
End With
End If
Next ColCount
Next RowCount
End With
Next Sht

Else
With Sheets(Sht)
'get column of date
StrDate = Format(MyDate, "d-mmm-yy")
Set c = .Rows(1).Find(what:=StrDate, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Date Error - Can't find date : " & StrDate)
Else

LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
Amount = .Cells(RowCount, c.Column)
If Amount < 0 Then

Name = .Range("A" & RowCount)
PayCAT = .Range("B" & RowCount)
MyDate = .Range("C" & RowCount)

With Sheets("Sheet3")
.Range("A" & NewRow) = Name
.Range("B" & NewRow) = PayCAT
.Range("C" & NewRow) = MyDate
.Range("D" & NewRow) = Amount
NewRow = NewRow + 1
End With
End If
Next RowCount
End If
End With
End If

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=165248

Microsoft Office Help