Searching 3 columns of values greater than 0 then pasting it to another sheet

[xjpx]

Hi all, I recently started VBA for Excel for a work of mine but I haven't been able to carry out a task I am doing. I hope someone could help me out. The procedure is as follows:

1. Search columns "BR" , "BU" and "BX" for all values above 0.
2. Copy all these values and paste it in a column of another sheet of the same workbook, "Sheet 2"
3. For all the searched values, copy another set of data in the same row as it in column "GU" into "Sheet 2"

I hope my explanation is enough. If anyone requires more information please let me know.

John

 

[bebo021999]

1) Do you want to paste into same column, same row of sheet2?
2) Or solid paste (BR, then BU, then BX, one after one) into which column sheet2?
3) it would help if you upload a screenshot/image

 

[xjpx]

@bebo021999 Hi, for example, for Column BR has a value 99, column BU has a value 70 and 8110 (first to third image). Then I want to paste it into "Sheet2" in a column (fourth image). At the same time I want to copy the data in the same rows as the 3 values "99","70" and "8110" in column "GU" which is the time (fifth image). The final product should look like the sixth image which is in sheet 2.

 

[bebo021999]

Option Explicit
Sub test()
Dim Lr1&, Lr2&, Lr3&, i&
Dim cell As Range
Dim arr(1 To 1000000, 1 To 2)
With Sheets("Sheet1")
    Lr1 = .Cells(Rows.Count, "BR").End(xlUp).Row
    Lr2 = .Cells(Rows.Count, "BU").End(xlUp).Row
    Lr3 = .Cells(Rows.Count, "BX").End(xlUp).Row
    For Each cell In .Range("BR2:BR" & Lr1)
        If cell > 0 Then
            i = i + 1
            arr(i, 1) = cell
            arr(i, 2) = cell.Offset(, 133)
        End If
    Next
        For Each cell In .Range("BU2:BU" & Lr2)
            If cell > 0 Then
                i = i + 1
                arr(i, 1) = cell
                arr(i, 2) = cell.Offset(, 130)
            End If
        Next
            For Each cell In .Range("BX2:BX" & Lr3)
                If cell > 0 Then
                    i = i + 1
                    arr(i, 1) = cell
                    arr(i, 2) = cell.Offset(, 127)
                End If
            Next
End With
Sheets("Sheet2").Cells(2, 1).Resize(i, 2).Value = arr
End Sub

 

[xjpx]

Option Explicit
Sub test()
Dim Lr1&, Lr2&, Lr3&, i&
Dim cell As Range
Dim arr(1 To 1000000, 1 To 2)
With Sheets("Sheet1")
    Lr1 = .Cells(Rows.Count, "BR").End(xlUp).Row
    Lr2 = .Cells(Rows.Count, "BU").End(xlUp).Row
    Lr3 = .Cells(Rows.Count, "BX").End(xlUp).Row
    For Each cell In .Range("BR2:BR" & Lr1)
        If cell > 0 Then
            i = i + 1
            arr(i, 1) = cell
            arr(i, 2) = cell.Offset(, 133)
        End If
    Next
        For Each cell In .Range("BU2:BU" & Lr2)
            If cell > 0 Then
                i = i + 1
                arr(i, 1) = cell
                arr(i, 2) = cell.Offset(, 130)
            End If
        Next
            For Each cell In .Range("BX2:BX" & Lr3)
                If cell > 0 Then
                    i = i + 1
                    arr(i, 1) = cell
                    arr(i, 2) = cell.Offset(, 127)
                End If
            Next
End With
Sheets("Sheet2").Cells(2, 1).Resize(i, 2).Value = arr
End Sub

Thank you! It runs and is able to copy out the Faults. But how do I copy the time, column "GU", into sheet 2 as well? As seen in the second image

 

[bebo021999]

What! I believe that I copy both:
arr(i, 1) = cell =>" Fault
arr(i, 2) = cell.Offset(, 127) => Time

And paste:
Sheets("Sheet2").Cells(2, 1).Resize(i, 2).Value = arr

Above is for column BX. 127 is distance from column BX to GU.

 

[xjpx]

What! I believe that I copy both:
arr(i, 1) = cell =>" Fault
arr(i, 2) = cell.Offset(, 127) => Time

And paste:
Sheets("Sheet2").Cells(2, 1).Resize(i, 2).Value = arr

Above is for column BX. 127 is distance from column BX to GU.

Yes, I understand what you are doing but it still doesn't copy the time.

 

[xjpx]

Yes, I understand what you are doing but it still doesn't copy the time.

Alright I managed to copy out the time. Thank you so much sir!

 

[bebo021999]

It still works for me!
You can test by debug.print within first loop
IN VBA edit mode, Ctrl-G to open "Immediate window" to see:

Option Explicit
Sub test()
Dim Lr1&, Lr2&, Lr3&, i&
Dim cell As Range
Dim arr(1 To 1000000, 1 To 2)
With Sheets("Sheet1")
    Lr1 = .Cells(Rows.Count, "BR").End(xlUp).Row
    Lr2 = .Cells(Rows.Count, "BU").End(xlUp).Row
    Lr3 = .Cells(Rows.Count, "BX").End(xlUp).Row
    For Each cell In .Range("BR2:BR" & Lr1)
        If cell > 0 Then
            i = i + 1
            arr(i, 1) = cell
            arr(i, 2) = cell.Offset(, 133)
debug.print arr(i,2) ' add this to print out the instant results.
        End If
    Next
        For Each cell In .Range("BU2:BU" & Lr2)
            If cell > 0 Then
                i = i + 1
                arr(i, 1) = cell
                arr(i, 2) = cell.Offset(, 130)
            End If
        Next
            For Each cell In .Range("BX2:BX" & Lr3)
                If cell > 0 Then
                    i = i + 1
                    arr(i, 1) = cell
                    arr(i, 2) = cell.Offset(, 127)
                End If
            Next
End With
Sheets("Sheet2").Cells(2, 1).Resize(i, 2).Value = arr
End Sub

 

[bebo021999]

Alright I managed to copy out the time. Thank you so much sir!

Nice to hear it works!