Lousy routine to get the first available day of the month

[Frank]

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]

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).

 

[Frank]

Hi Dave:

Thanks for your help.

Using .Formula = "=IF(TEXT(A2,""yyyymm"")<>TEXT(A1,""yyyymm"")," &
"""keepit"","""")" was brilliant!

Since I don’t need to keep the data (which is sorted by ascending date
and has no filter), I incorporated your solution as follows:

Dim RngToSort As Range
Dim LastRow As Long
Dim LastCol As Long

'insert two new temporary columns (B:C)
Range("B1").Resize(1, 1).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 Range("B2:B" & LastRow)
.NumberFormat = "General" 'make sure it's not Text
.Formula = "=IF(TEXT(A2,""yyyymm"")<>TEXT(A1,""yyyymm""),A2,"""")"
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
.Cells.NumberFormat = "m/d/yyyy"
.Cells.Value = .Cells.Value
End With

RngToSort.Sort key1:=Columns(2), order1:=xlAscending, header:=xlYes

Range(Range("B2").End(xlDown).Offset(1, -1),
Range("B2").End(xlDown).Offset(1, -1).SpecialCells(xlLastCell)).Delete
Columns("A:A").Delete Shift = xlToLeft

But the rest of your code is something I probably will use in other
application.

I need to learn about "resize". I have the VBA bible book, I just need
to get familiar with that function.

Regards,