Thread: VBA to copy data into other sheets based on specific criteria’s

Hello,
I need your help in preparing a Dash Board. I have an excel file with data pulled from external source & have lot of dump in it. I am looking for specific data that need to be pulled from that dump and saved in another sheet of the same file (as in example file).

In the Received Sheet:
1. It should prompt for the date and after entering the date (21- Jan in example file) it should fetch the data of Team A to Team E and paste it in Received Sheet based on Column L (Insert_time).
2. If this sheet is not available it should create a new one, if the sheet is already available then it need to clear the old data and paste the new one.

In the Closed Sheet:
1. It should prompt for the date and after entering the date (21- Jan in example file) it should fetch the data of Team A to Team E and paste it in Closed Sheet based on Column N (Close_Time) & Column U (Status of only “Closed”, “Closure Pending”, “Verified Closed”)
2. If this sheet is not available it should create a new one, if the sheet is already available then it need to clear the old data and paste the new one.

In Open Sheet:
1. It should fetch the data of Team A to Team E based on Column U (Status of only “Open”, “New”, “pending”)

I have attached the sample spread sheet for your reference. Sorry if my request is not clear.

Thanks in advance for your help!!

Regards,
Humac

Your sample data shows Teams F, G & X along with Teams A to E. What should be done for these 3 teams?

Sorry, i have another question - in your first post, you have mentioned that the code needs to prompt for the date twice, will the dates in both prompts be the same? Can the prompt be given only once in that case?

While working on the code for your request, i landed upon another doubt - will the sheets Received, Closed and Open be blank when the data will be copied over? So i can just search for the date provided and then copy the contents over from sheet1 to the required sheet?

Humac, last nite the forum was down for some time during the upgrade to the new server. I will try something now and post it.

Use this code - it takes care of all 3 requirements -

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 dd-mmm", "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
    End If
    
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lrow
        If .Range("L" & i).Value = 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
    
    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
    End If
    
    For i = 2 To lrow
        If .Range("N" & i).Value = 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
    
    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
    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
    
End With

Application.ScreenUpdating = True

End Sub

Hello Arlette,

I have tested the code in Orgianl data, it is creating all the required sheets but once I enter the date it is not copying data in Received & Closed Sheets. I have attached the sample sheet. please have a check.

I have entered 25-Jan as Date.

Regards,
Humac