[SOLVED]Help with VBA Macro - Returning Entire Row

Wats up,

I'm trying to return an entire row of data based on the values in one column.

Attached is what I have so far. This is all being done via Button 1.

User is to input a min and max value, which is then searched in Column E. If it is found, the row is to be returned in addition to the adjacent row, which is located above or below it. One row has the date in Column A, and the other row has the time in Column A.

The below code was given to me by jaslake, but currently all it does is put an asterisk next to the two rows.

Sub Button1_Click()
    Dim LR As Long
    Dim rng As Range
    Dim cel As Range
    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")
    With ws
        LR = .Range("E" & .Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(5, 5), .Cells(LR, 5))
        With rng
            For Each cel In rng
                If cel >= ws.Range("B19").Value And cel <= ws.Range("B20").Value Then
                    If InStr(ws.Range("A" & cel.Row).Text, "-") <> 0 Then
                        ws.Range("A" & cel.Row).Offset(0, 3).Resize(2, 1).Value = "*"
                    ElseIf InStr(ws.Range("A" & cel.Row).Text, ":") <> 0 Then
                        ws.Range("A" & cel.Row).Offset(-1, 3).Resize(2, 1).Value = "*"
                    End If
                End If
            Next cel
        End With
    End With
End Sub

The code actually checks to see if the row has a DATE or TIME in column A. The DATE is always in the first row and the TIME is always in the 2nd row. Based on Column A (After column E is searched), it determines which is the adjacent row.

Now I just need the data for both rows to be extracted to Sheet 2, each value receiving its own column.

Ex:
A B C D
2-6 Wed 3:00 2a 8
2-6 Wed 3:00 2b 9

*Adjacent rows share the same date and time.

Thanks for reading and for the help if possible.

Hi BamBam,

Try this:

Sub Button1_Click()
    Dim LR As Long, R As Long: R = 2
    Dim rng As Range
    Dim cel As Range
    Dim ws As Worksheet, wo As Worksheet
    Set ws = Sheets("Sheet1"): Set wo = Sheets("Sheet2")
    With ws
        LR = .Range("E" & .Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(5, 5), .Cells(LR, 5))
        With rng
            For Each cel In rng
                If cel >= ws.Range("B19").Value And cel <= ws.Range("B20").Value Then
                    If InStr(ws.Range("A" & cel.Row).Text, "-") <> 0 Then
        ws.Range("A" & cel.Row).Resize(2, 1).EntireRow.Copy wo.Range("A" & R): R = R + 2
                    ws.Range("A" & cel.Row).Offset(0, 3).Resize(2, 1).Value = "*"
                    ElseIf InStr(ws.Range("A" & cel.Row).Text, ":") <> 0 Then
        ws.Range("A" & cel.Row).Resize(2, 1).EntireRow.Copy wo.Range("A" & R): R = R + 2
                    ws.Range("A" & cel.Row).Offset(-1, 3).Resize(2, 1).Value = "*"
                    End If
                End If
            Next cel
        End With
    End With
End Sub

Hello BamBamMoneyBags,

This revision of the macro will copy the rows to "Sheet2" column "A:D". The macro has been added to the attached workbook.

Sub Button1_Click()

    Dim Data As Variant
    Dim n As Integer
    Dim nMax As Double
    Dim nMin As Double
    Dim r As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim RngOut As Range
    Dim Wks As Worksheet
    
    
        ReDim Data(1 To 4, 1 To 1)
        
        Set RngOut = Worksheets("Sheet2").Range("A1:D1")
        Set Wks = Worksheets("Sheet1")
        
        Set Rng = Wks.Range("A5")
        Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
        
        If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd).Resize(ColumnSize:=5)
        
        
        nMin = Wks.Cells(19, "B")
        nMax = Wks.Cells(20, "B")
        
            For r = 1 To Rng.Rows.Count - 1 Step 2
                If Rng.Item(r, 5) >= nMin And Rng.Item(r + 1, 5) <= nMax Then
                    
                    n = n + 1
                    ReDim Preserve Data(1 To 4, 1 To n)
                    Data(1, n) = Rng.Item(r, 1)
                    Data(2, n) = Rng.Item(r + 1, 1)
                    Data(3, n) = Rng.Item(r, 3)
                    Data(4, n) = Rng.Item(r, 5)
                    
                    n = n + 1
                    ReDim Preserve Data(1 To 4, 1 To n)
                    Data(1, n) = Rng.Item(r, 1)
                    Data(2, n) = Rng.Item(r + 1, 1)
                    Data(3, n) = Rng.Item(r + 1, 3)
                    Data(4, n) = Rng.Item(r + 1, 5)
                    
                End If
            Next r
        
        Data = Application.Transpose(Data)
        RngOut.Resize(UBound(Data), 4).Value = Data
        
End Sub