How to do a loop involving dates using VBA excel?

Question

I need to get values from a sheet with criteria involving dates. Range of date will be from Jan 1 up to Jan 31. I did some coding but honestly, not good with loops. Hopefully you can help me with these. So the process will be, I am filtering the data, for example, for column B, I am filtering Jan. 1, then the data from column A will be copy and paste to another sheet. After that, I am filtering again Jan. 2, copy the data from column A and paste again to another sheet, and so on...

Option Explicit

Sub Macro2()
'
' Macro2 Macro
'
'

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With



    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "1/1/2019")
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("January").Select
    Range("P5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("P:P").EntireColumn.AutoFit
    Range("A1").Select
    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2
    Range("A1").Select


    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "1/2/2019")
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("January").Select
    Range("Q5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("Q:Q").EntireColumn.AutoFit
    Range("A1").Select
    Sheets("Data").Select
    ActiveSheet.Range("$A$1:$B$1000").AutoFilter Field:=2
    Range("A1").Select


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Answer 1

Can also consider do so:

Sub TransferDate()

For Each cell In Worksheets("Data2").Columns(1).Cells
    If cell.Value = "" Then Exit Sub

    If IsDate(cell.Value) Then
        Mth = MonthName(Month(cell.Value))
        DayDate = Day(cell.Value)
        Worksheets(Mth).Cells(Rows.Count, DayDate + 15).End(xlUp).Offset(1).Value = cell.Value
        Worksheets(Mth).Columns(DayDate + 15).EntireColumn.AutoFit
    End If
Next

End Sub

Answer 2

• If you just want all dates from January 2019 and aren't bothered about the order in which they appear on your January worksheet, you could just get rid of the loop (in the code below) and specify once: "greater than or equal to 1 January 2019" and "less than 1 February 2019". (It should be quicker than looping but the order of the output will reflect/match whatever it was on the original sheet.)
• On the other hand if you're sure you want to loop, you can try the code below. The Application settings can be uncommented once you know the code works correctly. (I could not test it as I don't know what your sheet looks like.)
• My filter criteria assume the hour, minute and second components of your dates are all 0. If this is not true, you may need to adjust Criteria1 and Criteria2 accordingly.
• Currently, the output will be contiguous. For example, say your Data sheet is as below:
  • contains 28 January 2019
  • does not contain 29 January 2019
  • contains 30 January 2019
• Then the output will be something like:
  • data for 28 January 2019 in some column
  • data for 30 January 2019 in the immediately next column
• In other words, no blank column will be present in the output to reflect the "missing date". If you don't have any "missing dates", this is a non-issue. But if your January sheet expects a blank column (for each missing date), you can move the pasteOffset = pasteOffset + 1 line outside of the IF (after it).

---

Option Explicit

Sub Macro2() ' Needs renaming.

    With Application
        '.ScreenUpdating = False
        '.EnableEvents = False
    End With

    Dim sourceSheet As Worksheet
    Set sourceSheet = Worksheets("Data")

    Dim destinationSheet As Worksheet
    Set destinationSheet = Worksheets("January") ' Could also determine this dynamically inside the loop, rather than hardcoding here.
    destinationSheet.Cells.Clear

    Dim includingHeaders As Range
    Set includingHeaders = sourceSheet.Range("A1:B1000")

    Dim excludingHeaders As Range
    Set excludingHeaders = includingHeaders.Offset(1).Resize(includingHeaders.Rows.Count - 1, 1)

    Dim dateIndex As Date
    For dateIndex = DateSerial(2019, 1, 1) To DateSerial(2019, 1, 31) ' Could use date literals instead (if you wanted to).
        ' Not sure if this is the best way to exactly match a date.
        includingHeaders.AutoFilter Field:=2, Criteria1:=">=" & CLng(dateIndex), Operator:=xlAnd, Criteria2:="<=" & CLng(dateIndex)

        ' Range.SpecialCells method is called twice, which is inefficient.
        If includingHeaders.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            excludingHeaders.SpecialCells(xlCellTypeVisible).Copy

            Dim pasteOffset As Long
            destinationSheet.Range("P5").Offset(0, pasteOffset).PasteSpecial xlPasteValuesAndNumberFormats
            pasteOffset = pasteOffset + 1 ' This is only incremented if the date exists in column B.
        End If
    Next dateIndex

    sourceSheet.AutoFilterMode = False

    With Application
        .CutCopyMode = False
        '.ScreenUpdating = True
        '.EnableEvents = True
    End With
End Sub