Macro to copy row title to a different sheet based on multiple column criteria

[Steveb03]

Hi,

I am having trouble figuring out the correct code that will copy the Row title on Sheet 1 to Sheet 2 based on criteria in columns E & F on Sheet one.

The Criteria required needed to return the building name is no activity in 2014, column E, and activity in 2015 ,column F, any activity is acceptable both positive and negative. If the criteria is met I am trying to copy the building name to sheet two, if the criteria is not met then move on to the next row.

I have attached an example spreadsheet. Also, if there are formulas that would work better I am not opposed to using them.

Thanks in advance for the help.

[Mumps1]

Try:

Sub CopyName()
    Dim bottomA As Integer
    bottomA = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    Dim c As Range
    For Each c In Sheets("Sheet1").Range("A2:A" & bottomA)
        If c.Offset(0, 4) = "" And c.Offset(0, 5) <> "" Then
            c.Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next c
End Sub

[Steveb03]

Hey Mumps1,

A small follow up question. In my actual spreadsheet I need to run the macro for only rows 50-100 of 'Sheet1' with there being information on the rows above and below that range. How could I update your code to only run the macro on that range?

Thanks again.

[JieJenn]

Sub test()
Dim Col As Collection
Dim LR As Long, i As Long
Dim j5 As Integer, j6 As Integer, j As Integer

Set Col = New Collection

j5 = 5
j6 = 6

With Worksheets("Sheet1")
LR = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LR
        If .Cells(i, j5).Value = 0 Then
            On Error Resume Next
            Col.Add .Cells(i, 1).Value, CStr(.Cells(i, 1).Value)
        End If
        
        If .Cells(i, j6).Value <> 0 Then
            On Error Resume Next
            Col.Add .Cells(i, 1).Value, CStr(.Cells(i, 1).Value)
        End If
    Next i
End With

With Worksheets("Sheet2")
    For j = 1 To Col.Count
        .Cells(j + 3, 1) = Col(j)
    Next j
End With
End Sub

[Steveb03]

It works! Thanks!

[Mumps1]

Hi Steve:

Use this code instead:

Sub CopyName()
    Dim c As Range
    For Each c In Sheets("Sheet1").Range("A50:A100")
        If c.Offset(0, 4) = "" And c.Offset(0, 5) <> "" Then
            c.Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next c
End Sub

[Steveb03]

Thank you!

[Mumps1]

It was my pleasure.