CODEWITHSUNDEEP
vbaexcel
Jimmy8t8
Jimmy8t8

Reputation: 55

VBA: Prompt for date and copy the cells with that date into worksheet 2 macro

I am having trouble with the code below, what I would like is the user to enter in any date and then when user presses enter, it copies and pastes all the rows with that date in question to worksheet 2?

I am quite new to VBA so any help would be greatly appreciated.

Sub test()

strName = InputBox(Prompt:="Enter the date.", _
Title:="ENTER DATE", Default:="dd:mm:yy")

Dim cell As Excel.Range
 RowCount = DataSheet.UsedRange.Rows.Count
 Set col = DataSheet.Range("B1:B" & RowCount)
 Dim SheetName As String
 Dim cellValues() As String

 For Each cell In col

 cellValues = cell.Value
 SheetName = cellValues(0)

 If SheetName = strName Then
 cell.EntireRow.Copy

'and then paste into worksheet2

 End If
 Next
 End Sub

Here is the worksheet macro that auto-inputs the date:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Cells.Count > 1 Then Exit Sub

        If Not Intersect(Target, Range("A2:A100001")) Is Nothing Then

            With Target(1, 2)

                .Value = Date

                .EntireColumn.AutoFit

            End With

        End If

End Sub

Upvotes: 0

Views: 2911

Answers (1)

DyRuss
DyRuss

Reputation: 502

Assuming DataSheet is the name of the Worksheet you want to look for the dates in, and assuming "Sheet2" is a worksheet that exists and is where you want to paste the data, then the below code should work. BTW if DataSheet is the ActiveSheet then there is no need to reference it in the code as VBA assumes it is the sheet you want to work with. If Sheet2 doesn't exist yet, add the line Worksheets.Add.Name = "Sheet2" before the For loop.

Sub test()
    Dim LastRowinB, CurrentRow, NextBlankRow As Long
    Dim strName As String
    NextBlankRow = 1
    LastRowinB = Worksheets("DataSheet").Range("B1048576").End(xlUp).Row

    strName = InputBox(Prompt:="Enter the date.", _
    Title:="ENTER DATE", Default:="dd:mm:yy")

    For CurrentRow = 1 To LastRowinB
        If strName = Worksheets("DataSheet").Range("B" & CurrentRow) Then
            Worksheets("DataSheet").Range("B" & CurrentRow).EntireRow.Copy
            Worksheets("Sheet2").Range("A" & NextBlankRow).PasteSpecial xlPasteAll
            NextBlankRow = NextBlankRow + 1
        End If
    Next
End Sub

Upvotes: 0

Related Questions