Excel VBA-如何提取特定行

Question

我在一個Excel電子表格中有多個“房間”，想提取房間，姓名，筆記本電腦，品牌和經理，但不包括教師和預算。

   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

我試圖通過修改以下代碼來提取我需要的所有數據，但是很難以與示例中相同的順序來獲取數據。

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

預先感謝您的幫助。

Answer 1

如果您的“源”工作表具有首個標題標題，則可以使用AutoFilter（）方法僅過濾相關記錄並將其粘貼到一個鏡頭中：

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

對代碼進行以下更改即可：

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

我使用Select Case語句來省去編寫稍長的If語句的麻煩，而我只是查看A列的前4個字符，以便它處理Room x#類型的單元格。

---

如果您需要在大多數值之后添加空白行（“ Room”除外），那么我建議對上面的代碼進行一些修改：

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