Excel VBA-How to Extract Specific Rows

Question

I have multiple "Rooms" in an excel spread sheet and would like to extract the Room, Name, Laptops, Make and Manager while excluding Faculty and Budget.

   Room 1#  |
   Name     |   Office2
            |
   Laptops  |   22
            |
   Make     |   Mac
            |
   People   |   17
            |
   Faculty  |   Accounts
            |
   Manager  |   John
            |
   Budget   |  xxxxx
            |
   Room 2#  |
            |
   Name     |   Office3
            |
   Laptops  |   22
            |
   Make     |   HP
            |
   People   |   20
            |
   Faculty  |   Marketimg
            |
   Manager  |   Jeff
            |
   Budget   |  xxxxx

I am trying to extract all the data I require by modifying the following code but am having difficulty in getting the data in the same order as it is in the sample.

Sub CopyManager()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    J = 1     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("A1:A1000")   ' Do 1000 rows
        If c = "Manager" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub

Thank you in advance for your help.

Answer 1

Provided your Source sheet has a first riw for headers, you could use AutoFilter() method to filter only relevant records and paste them in one shot:

Sub CopyManager()
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim valsArray As Variant

    valsArray = Array("Room*", "Name", "Laptops", "Make","Manager") '<--| define your values to be filtered on Source sheet column A
    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    With Source  '<--| reference Source sheet
        With .Range("A1:A1000")  '<--| reference its range from A1 to A1000
            .AutoFilter Field:=1, Criteria1:= valsArray, Operator:=xlFilterValues  '<--| filter referenced range on its first column with values stored in valsArray
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell filtered other than 
                .Resize(.Rows.count - 1, 2).Offset(1).SpecialCells(xlCellTypeVisible).Copy Target.Range("A1") '<--|copy filtered cells skipping headers and paste in target sheet from cell A1
            End If
        End With
        .AutoFilterMode= False
    End With
End Sub

Answer 2

The following change to your code should do it:

Sub CopyManager()
    Dim r As Long
    Dim j As Long
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    J = 1     ' Start copying to row 1 in target sheet
    For r = 1 To 1000   ' Do 1000 rows
        Select Case Left(Trim(Source.Cells(r, 1).Value), 4)
            Case "Mana", _
                 "Make", _
                 "Room", _
                 "Name", _
                 "Lapt"
                Source.Rows(r).Copy Target.Rows(j)
                j = j + 1
        End Select
    Next
End Sub

I use a Select Case statement to save having to write a slightly longer If statement, and I just look at the first 4 characters of column A so that it handles Room x# type cells.

---

If you needed blank rows after most of the values (except for "Room"), I would suggest a slight rework of my code above:

Sub CopyManager()
    Dim r As Long
    Dim j As Long
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    J = 1     ' Start copying to row 1 in target sheet
    For r = 1 To 1000   ' Do 1000 rows
        Select Case Left(Trim(Source.Cells(r, 1).Value), 4)
            Case "Mana", _
                 "Make", _
                 "Name", _
                 "Lapt"
                Source.Rows(r & ":" & (j + 1)).Copy Target.Rows(j & ":" & (j + 1))
                'or, if the "|" in your example is just signifying a new column, use the simpler
                Source.Rows(r).Copy Target.Rows(j)

                j = j + 2
            Case "Room"
                Source.Rows(r).Copy Target.Rows(j)
                j = j + 1
        End Select
    Next
End Sub