Data between two dates

[humacdeep]

Hello,

I got the below code for Arlette and it is working as desired(Data for particular date). I need your help to modify the same code to generate the report between two dates.

I have attached the sample file for your reference.

http://www.excelforum.com/excel-prog...riteria-s.html

Option Explicit
Dim userdate As Date
Dim lrow As Long
Dim i As Long
Dim lastrow As Long

Sub copy_data()

Application.ScreenUpdating = False

userdate = InputBox("Please enter the date in format mm/dd/yy", "Enter Date")

With Worksheets("Sheet1")
    If Not Evaluate("ISREF('Received'!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Received"
        .Rows("1:1").Copy Worksheets("Received").Range("A1")
    Else
        lastrow = Worksheets("Received").Range("A" & Rows.Count).End(xlUp).Row
        Worksheets("Received").Range("A2:U" & lastrow).ClearContents
        .Rows("1:1").Copy Worksheets("Received").Range("A1")
    End If
    
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lrow
        If .Range("L" & i).Value Like userdate & "*" Then
            If .Range("S" & i).Value = "Team A" Or .Range("S" & i).Value = "Team B" Or .Range("S" & i).Value = "Team C" Or _
                .Range("S" & i).Value = "Team D" Or .Range("S" & i).Value = "Team E" Then
                    .Range("A" & i & ":U" & i).Copy Worksheets("Received").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        End If
    Next i
    
    Worksheets("Received").Cells.EntireColumn.AutoFit
    
    If Not Evaluate("ISREF('Closed'!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Closed"
        .Rows("1:1").Copy Worksheets("Closed").Range("A1")
    Else
        lastrow = Worksheets("Closed").Range("A" & Rows.Count).End(xlUp).Row
        Worksheets("Closed").Range("A2:U" & lastrow).ClearContents
        .Rows("1:1").Copy Worksheets("Received").Range("A1")
    End If

     For i = 2 To lrow
        If .Range("N" & i).Value Like userdate & "*" Then
            If .Range("S" & i).Value = "Team A" Or .Range("S" & i).Value = "Team B" Or .Range("S" & i).Value = "Team C" Or _
                .Range("S" & i).Value = "Team D" Or .Range("S" & i).Value = "Team E" Then
                If .Range("U" & i).Value = "Closed" Or .Range("U" & i).Value = "Closure Pending" Or .Range("U" & i).Value = "Verified closed" Then
                    .Range("A" & i & ":U" & i).Copy Worksheets("Closed").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            End If
        End If
    Next i
    
    Worksheets("Closed").Cells.EntireColumn.AutoFit

    If Not Evaluate("ISREF('Open'!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Open"
        .Rows("1:1").Copy Worksheets("Open").Range("A1")
    Else
        lastrow = Worksheets("Open").Range("A" & Rows.Count).End(xlUp).Row
        Worksheets("Open").Range("A2:U" & lastrow).ClearContents
        .Rows("1:1").Copy Worksheets("Received").Range("A1")
    End If

    For i = 2 To lrow
        If .Range("S" & i).Value = "Team A" Or .Range("S" & i).Value = "Team B" Or .Range("S" & i).Value = "Team C" Or _
                .Range("S" & i).Value = "Team D" Or .Range("S" & i).Value = "Team E" Then
                If .Range("U" & i).Value = "New" Or .Range("U" & i).Value = "Open" Or .Range("U" & i).Value = "Pending" Then
                    .Range("A" & i & ":U" & i).Copy Worksheets("Open").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
        End If
    Next i
    
    Worksheets("Open").Cells.EntireColumn.AutoFit

End With

Application.ScreenUpdating = True

End Sub

Regards,
Humac

[snb]

I think you better reduce this code's redundancy first.

[humacdeep]

Hi Snb,

I am basic learner of VBA. Could you please help me in modifing the below code?

Option Explicit
Dim userdate As Date
Dim lrow As Long
Dim i As Long
Dim lastrow As Long

Sub copy_data()

Application.ScreenUpdating = False

userdate = InputBox("Please enter the date in format mm/dd/yy", "Enter Date")

With Worksheets("Sheet1")
    If Not Evaluate("ISREF('Received'!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Received"
        .Rows("1:1").Copy Worksheets("Received").Range("A1")
    Else
        lastrow = Worksheets("Received").Range("A" & Rows.Count).End(xlUp).Row
        Worksheets("Received").Range("A2:U" & lastrow).ClearContents
        .Rows("1:1").Copy Worksheets("Received").Range("A1")
    End If
    
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lrow
        If .Range("L" & i).Value Like userdate & "*" Then
           .Range("A" & i & ":U" & i).Copy Worksheets("Received").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        End If
    Next i
    
    Worksheets("Received").Cells.EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

[snb]

Sub copy_data()
  Application.ScreenUpdating = False

  With sheets("Sheet1")
    If Not Evaluate("ISREF('Received'!A1)") Then
      sheets.Add.Name = "Received"
    else
      Sheets("Received").usedRange.offset(1).ClearContents
    end if
    .Rows(1).Copy sheets("Received").Rows(1)
    
    with .usedrange
      .autofilter 12, "=" & InputBox("Please enter the date in format mm/dd/yyyy", "Enter Date")& "*"
      .offset(1).copy sheets("Received").cells(2,1)
      .autofilter
   end with 
  
   Sheets("Received").Columns.AutoFit

  Application.ScreenUpdating = True
End Sub

[humacdeep]

Hi SNB,

Thanks for the code, I am getting Run time error '1004' at below line (AutoFilter method of Range class failed).

.AutoFilter 12, "=" & InputBox("Please enter the date in format mm/dd/yyyy", "Enter Date") & "*"

Also does this code ask for From & To date as I mentioned earlier?

Regards,
Humac

[humacdeep]

Hi Snb,

Did you get a chance to look into us?

Regards,
Humac

[humacdeep]

Bump no responce.

[watersev]

hi humacdeep, try this option based on snb code posted above:

Sub copy_data()

Application.ScreenUpdating = False

With Sheets("Sheet1")
  
  If Not Evaluate("ISREF('Received'!A1)") Then
    Sheets.Add.Name = "Received"
  Else
    Sheets("Received").UsedRange.Offset(1).ClearContents
  End If
  
  On Error Resume Next

  With .UsedRange
    .AutoFilter 12, ">" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 23:59")), xlAnd, "<" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 00:00"))
    .Offset(1).Copy Sheets("Received").Cells(2, 1)
    .AutoFilter
  End With

End With
  
Sheets("Received").Columns.AutoFit

Application.ScreenUpdating = True

End Sub

[humacdeep]

Thanks for the code Watersev...

In which format the date need to be given? I have tried with all the formats (MM/DD/YYYY, M/DD/YY, MM/DD/YY) but it not populating the data. Couldyou please have a check?

Reagrds,
Humac

[Lifeseeker]

hi humacdeep, try this option based on snb code posted above:

Sub copy_data()

Application.ScreenUpdating = False

With Sheets("Sheet1")
  
  If Not Evaluate("ISREF('Received'!A1)") Then
    Sheets.Add.Name = "Received"
  Else
    Sheets("Received").UsedRange.Offset(1).ClearContents
  End If
  
  On Error Resume Next

  With .UsedRange
    .AutoFilter 12, ">" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 23:59")), xlAnd, "<" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 00:00"))
    .Offset(1).Copy Sheets("Received").Cells(2, 1)
    .AutoFilter
  End With

End With
  
Sheets("Received").Columns.AutoFit

Application.ScreenUpdating = True

End Sub

Hi there,

I'm studying the code.

I still need to understand what the offset() does.

 .Offset(1).Copy Sheets("Received").Cells(2, 1)

If we didn't have the .offset(1), what would the macro do?

[watersev]

with Regional settings for US, and dates input in format - (m/dd/yyyy):
Start date: 1/24/2012
End date: 1/26/2012
The result is correct, sheet "Received" has all rows with 25 January 2012

[humacdeep]

I hope there was some issue in the attached file. I have copied the data into new sheet and now I got the same result. Thank You...

However its not adding the heading in the received sheet (it need to be same heading as Sheet1). Also the received sheet is getting created before sheet1, is it possible to get it created after sheet1?

Regards,
Humac

[watersev]

@Lifeseeker
Offset moves Usedrange one row down not to copy header

[Lifeseeker]

thank you Watersev

[watersev]

Sub copy_data()
  Application.ScreenUpdating = False

  With Sheets("Sheet1")
    If Not Evaluate("ISREF('Received'!A1)") Then
      Sheets.Add(after:=Sheets("Sheet1")).Name = "Received"
    Else
      Sheets("Received").UsedRange.ClearContents
    End If
    
    .Rows(1).Copy Sheets("Received").Rows(1)

    On Error Resume Next

    With .UsedRange
      .AutoFilter 12, ">" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 23:59")), xlAnd, "<" & CLng(CDate(InputBox("Please enter date", "Enter End Date") & " 00:00"))
      .Offset(1).Copy Sheets("Received").Cells(2, 1)
      .AutoFilter
   End With

  End With
  
   Sheets("Received").Columns.AutoFit

  Application.ScreenUpdating = True
End Sub

[humacdeep]

Thanks Watersev.. Its working great.

I have modified the same code as per my initial requirement in the thread. I am able to get the report as desired, but I need your help in getting the code corrected to ask for dates only one time instead of two times (In the below code it is asking One time for Received and another time for Closed).

Is it some thing possible?

Sub copy_data()
  Application.ScreenUpdating = False

  With Sheets("Sheet1")
    If Not Evaluate("ISREF('Received'!A1)") Then
      Sheets.Add(after:=Sheets("Sheet1")).Name = "Received"
    Else
      Sheets("Received").UsedRange.ClearContents
    End If
    
    .Rows(1).Copy Sheets("Received").Rows(1)

    On Error Resume Next

    With .UsedRange
      .AutoFilter 12, ">" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 23:59")), xlAnd, "<" & CLng(CDate(InputBox("Please enter date", "Enter End Date") & " 00:00"))
      .Offset(1).Copy Sheets("Received").Cells(2, 1)
      .AutoFilter

  End With
  
   Sheets("Received").Columns.AutoFit

  Application.ScreenUpdating = True
  

If Not Evaluate("ISREF('Closed'!A1)") Then
      Sheets.Add(after:=Sheets("Received")).Name = "Closed"
    Else
      Sheets("Closed").UsedRange.ClearContents
    End If
    
    .Rows(1).Copy Sheets("Closed").Rows(1)

    On Error Resume Next

    With .UsedRange
      .AutoFilter 14, ">" & CLng(CDate(InputBox("Please enter date", "Enter Start Date") & " 23:59")), xlAnd, "<" & CLng(CDate(InputBox("Please enter date", "Enter End Date") & " 00:00"))
      .Offset(1).Copy Sheets("Closed").Cells(2, 1)
      .AutoFilter
  
  End With
  
   Sheets("Closed").Columns.AutoFit

  Application.ScreenUpdating = True


If Not Evaluate("ISREF('Open'!A1)") Then
      Sheets.Add(after:=Sheets("Closed")).Name = "Open"
    Else
      Sheets("Open").UsedRange.ClearContents
    End If
    
    .Rows(1).Copy Sheets("Open").Rows(1)

    On Error Resume Next

    With .UsedRange
      .AutoFilter 14, "=" & ""
      .Offset(1).Copy Sheets("Open").Cells(2, 1)
      .AutoFilter
   End With

  End With
  
   Sheets("Open").Columns.AutoFit

  Application.ScreenUpdating = True

End Sub

Regards,
Humac

[humacdeep]

Hello Watersev,

Did you get a chance to look into this?

Regards,
Humac

[humacdeep]

Thanks all for your help!!

Watersev - Never mind, I have figured it out and its working as desired.

Regards,
Humac