Find and add missing months to table

[Shaun]

Hi All,

I have a list of dates which are assigned:

• Financial Year;
• Financial Quarter; and
  
• Month.

What I am trying to do is identify missing months in each of the financial years in the table and add the dummy data into the tables.

In the example attached the months missing are January 2015, June 2015, January 2016 and June 2016 Financial years. At the bottom of the table I would like to add the last date of those months (i.e. (format: dd/mm/yyyy) 31/01/2015, 30/06/2015, 31/01/2016 and 30/06/2016.

I will need to adapt the code from the example over multiple tables of varying row counts.

I tried to cycling through the years and months but I have not been able to get it to work.

I would appreciate someone taking a look, an example file is attached.

Cheers

Shaun

 

[Shaun]

Hi All,

It ain't pretty, but it gets the job done!

Sub MissingDates()

Dim RowNum As String
Dim LstRow As String
Dim LstRow1 As String
Dim LstRow2 As String
Dim LstRow3 As String
Dim strSearch As String
Dim Mth(1 To 12) As String
Dim sMth As String

Application.ScreenUpdating = False
Mth(1) = "Jul"
Mth(2) = "Aug"
Mth(3) = "Sep"
Mth(4) = "Oct"
Mth(5) = "Nov"
Mth(6) = "Dec"
Mth(7) = "Jan"
Mth(8) = "Feb"
Mth(9) = "Mar"
Mth(10) = "Apr"
Mth(11) = "May"
Mth(12) = "Jun"

If Rows.Count < 65537 Then
  RowNum = 65536
Else
  RowNum = Rows.Count
End If

LstRow = ActiveSheet.Range("B" & RowNum).End(xlUp).Row
Set rRng = ActiveSheet.Range("B5:B" & LstRow)
Debug.Print LstRow

Range("SalesVCOGS[FinYear]").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1"), Unique:=True
Range("F1").Select
Selection.ClearContents

LstRow1 = ActiveSheet.Range("F" & RowNum).End(xlUp).Row
Set rRng1 = ActiveSheet.Range("F2:F" & LstRow1)

For Each rcell In rRng
  rcell.Offset(0, 4) = rcell.Value & rcell.Offset(0, 2).Value
Next rcell

LstRow2 = ActiveSheet.Range("F" & RowNum).End(xlUp).Row

For Each rCell1 In rRng1
  For i = 1 To 12
  Select Case i
  Case 1
  sMth = "Jul"
  Case 2
  sMth = "Aug"
  Case 3
  sMth = "Sep"
  Case 4
  sMth = "Oct"
  Case 5
  sMth = "Nov"
  Case 6
  sMth = "Dec"
  Case 7
  sMth = "Jan"
  Case 8
  sMth = "Feb"
  Case 9
  sMth = "Mar"
  Case 10
  sMth = "Apr"
  Case 11
  sMth = "May"
  Case 12
  sMth = "Jun"
  End Select
  
  strSearch = rCell1.Value & sMth
  Debug.Print strSearch
  Set rRng2 = ActiveSheet.Range("F5:F" & LstRow2).Find(strSearch, , xlValues, xlWhole)

  If Not rRng2 Is Nothing Then
  Else
  Select Case i
  Case 1
  sMth = "31/07/" & rCell1.Value - 1
  Case 2
  sMth = "31/08/" & rCell1.Value - 1
  Case 3
  sMth = "30/09/" & rCell1.Value - 1
  Case 4
  sMth = "31/10/" & rCell1.Value - 1
  Case 5
  sMth = "30/11/" & rCell1.Value - 1
  Case 6
  sMth = "31/12/" & rCell1.Value - 1
  Case 7
  sMth = "31/01/" & rCell1.Value
  Case 8
  sMth = "28/02/" & rCell1.Value
  Case 9
  sMth = "31/03/" & rCell1.Value
  Case 10
  sMth = "30/04/" & rCell1.Value
  Case 11
  sMth = "31/05/" & rCell1.Value
  Case 12
  sMth = "30/06/" & rCell1.Value
  End Select
  LstRow3 = ActiveSheet.Range("B" & RowNum).End(xlUp).Row + 1
  ActiveSheet.Range("$A$" & LstRow3) = sMth
  End If
  Next i
Next rCell1
ActiveSheet.Range("F:F").Delete
Application.ScreenUpdating = True
End Sub

Cheers

Shaun