Lousy routine to get the first available day of the month
So...
You have a bunch of dates in column A (A2:A999, say). And there could be
duplicates for each date. You want to keep the first date in each month and
copy them somewhere else?
How about this technique:
1. Sort the data by the date column (ascending order).
2. Instead of parsing the date into month, day, year columns, you insert a
couple of columns to use as indicators to see if that record should be kept.
3. Then filter these results.
4. Copy|paste the visible rows to a new worksheet.
5. Delete the helper columns (from both sheets).
========
I'm gonna assume that the data has a header row with headers in each column.
And it also has a date in each row (A2:A999) so I can use these to determine
what to sort and filter.
In code:
Option Explicit
Sub testme()
Dim wks As Worksheet
Dim RptWks As Worksheet
Dim RngToSort As Range
Dim LastRow As Long
Dim LastCol As Long
Set wks = Worksheets("Sheet1") 'activesheet?
Set RptWks = Worksheets("Data") 'existing sheet.
With wks
'remove any existing filter
.AutoFilterMode = False
'insert two new temporary columns (B:C)
.Range("B1").Resize(1, 2).EntireColumn.Insert
'determine what to sort
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set RngToSort = .Range("A1", .Cells(LastRow, LastCol))
With RngToSort
.Sort key1:=.Columns(1), order1:=xlAscending, _
header:=xlYes, MatchCase:=False
End With
With .Range("B2:B" & LastRow)
.NumberFormat = "General" 'make sure it's not Text
.Formula = "=IF(TEXT(A2,""yyyymm"")<TEXT(A1,""yyyymm""), " _
& """keepit"","""")"
End With
With .Range("C2:C" & LastRow)
.NumberFormat = "General"
.Formula = "=VLOOKUP(A2,A:B,2,FALSE)"
End With
Application.Calculate 'just in case!
'convert to values (quicker filtering times
With .Range("B:C")
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
End With
RngToSort.AutoFilter field:=3, Criteria1:="Keepit"
With .AutoFilter.Range
'check to see if only the headers are visible
If .Columns(1).Cells.SpecialCells(xlCellTypeVisible) _
.Cells.Count = 1 Then
MsgBox "No details records found!"
Else
'remove the header and come down one row to the data
.Resize(.Rows.Count - 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=RptWks.Range("a2")
End If
End With
'remove the autofilter
.AutoFilterMode = False
'remove the helper columns
.Range("B1").Resize(1, 2).EntireColumn.Delete
'from the new sheet, too
RptWks.Range("B1").Resize(1, 2).EntireColumn.Delete
End With
End Sub
=========
The two formulas (in columns B and C) look like:
=IF(TEXT(A2,"yyyymm")<TEXT(A1,"yyyymm"),"keepit", "")
and
=VLOOKUP(A2,A:B,2,FALSE)
After the data is sorted by date (ascending), then column B will show a "keepit"
indicator if it's the first row of the month.
Then column C will return that same indicator for all the same dates (first date
in the month).
On 07/08/2010 17:31, Frank wrote:
I have a worksheet with dates and data. The date column only includes
business days from different countries.
I need to retrieve the first available business days for every month
and every year.
Here is my lousy yet working code.
I parse the A column, where the date reside) into 3 (month, day and
year) and sort the worksheet by day (column b). Then I autofilter each
month, autofilter each year and finally copy the results. I loop for
each month and each year.
It works but looks there must be a better and faster way.
BTW, I’m not a programmer, which explains the complicated code:
Application.ScreenUpdating = False
Columns("B:C").Insert Shift:=xlToRight
Columns("A:A").TextToColumns Destination:=Range("A1"),
DataType:=xlDelimited, TextQualifier:=xlNone, OtherChar:="/"
Columns("A:C").NumberFormat = "General"
Range("A1") = "month"
Range("B1") = "day"
Range("C1") = "year"
c = 1 'month
yhigh = Application.Max(Columns("C:C")) + 1 'the highest year
Range(("A1"), Range("A1").SpecialCells(xlLastCell)).Select
With Selection
.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes
Do Until c = 13 '12 = December
ylow = Application.Min(Columns("C:C")) 'reset the lowest year
.AutoFilter Field:=1, Criteria1:=c
Do Until ylow = yhigh
.AutoFilter Field:=3, Criteria1:=ylow
Selection.Copy
Sheets("data1").Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.EntireRow.Delete
ActiveCell.Offset(1, 0).Activate
Range(ActiveCell,
ActiveCell.SpecialCells(xlLastCell)).Delete
Sheets("data").Select
ylow = ylow + 1 'go through each year for specific month
(c)
Loop
c = c + 1 'goto next month
Loop
End With
Sheets("data1").Select
Range(("B1"), Range("B1").End(xlDown)) = 1 'each first day of the
month must equat 1
Range(("A1"), Range("A1").SpecialCells(xlLastCell)).Sort
Key1:=Range("C1"), Order1:=xlAscending, Key2:=Range("A1"),
Order2:=xlAscending, Header:=xlYes
--
Dave Peterson
|