如何使用第一列中的字符串名称将某些行复制到新(或现有)选项卡中？

Question

我有一个带有测压数据的电子表格。我正在使用的版本要大得多，我们每半年更新一次，但要点如下：

PZ #    Water EL    TIP    Pool   Tail
PZ-1A    888        864    910    880
PZ-1A    888        864    911    880
PZ-1A    888        864    912    880
PZ-1B    889        839    910    880
PZ-1B    889        839    911    880
PZ-1B    889        839    912    880
PZ-2     890        860    910    880
PZ-2     890        860    911    880
PZ-2     890        860    912    880

我需要为每个测压计制作一个新的(或有一个现有的)选项卡，例如，选项卡"PZ-1A“如下所示：

PZ #    Water EL    TIP    Pool   Tail
PZ-1A    888        864    910    880
PZ-1A    888        864    911    880
PZ-1A    888        864    912    880

标签"PZ-1B“如下所示

PZ #    Water EL    TIP    Pool   Tail
PZ-1B    889        839    910    880
PZ-1B    889        839    911    880
PZ-1B    889        839    912    880

标签"PZ-2“如下所示

PZ #    Water EL    TIP    Pool   Tail
PZ-2     890        860    910    880
PZ-2     890        860    911    880
PZ-2     890        860    912    880

诸若此类。我尝试过一些使用匹配单元格的方法，但是没有什么值得发布的。我知道，一旦我得到的是PZ-1A，它只是一个复制的代码，其余的问题。这是我需要的评论形式..。

Sub find()
    For Each cell In Range("A")
        'select all cells that match the text "PZ-1A"
            'copy these entire rows to a new sheet named 'PZ-1A'
        'select all cells that match the text "PZ-1B"
            'copy these entire rows to a new sheet named 'PZ-1B'
        'select all cells that match the text "PZ-2"
            'copy these entire rows to a new sheet named 'PZ-2'
    Next cell
End Sub

我将继续努力，但我确实还有很长的路要走。在学校，我学了一些Matlab，但那是很久以前的事了，现在我才刚刚开始我的VBA之旅。

有人有什么有用的建议/代码我可以使用吗？

Answer 1

Sub ProcessRows()

    Dim rng As Range, cell As Range
    Set rng = ActiveSheet.Range(ActiveSheet.Range("A2"), _
                     ActiveSheet.Cells(Rows.Count, 1).End(xlUp))

    For Each cell In rng.Cells
        cell.EntireRow.Copy CopyTo(cell)
    Next cell

End Sub

'Return a range object to which a row should be copied
'  Range returned is determined by the value in "rng"
Function CopyTo(rng As Range) As Range
    Dim s As Excel.Worksheet, sName As String

    sName = Trim(rng.Value) 'just in case...

    On Error Resume Next               'ignore any error
    Set s = ThisWorkbook.Sheets(sName) 'see if we can grab the sheet
    On Error GoTo 0                    'stop ignoring errors

    If s Is Nothing Then    'sheet didn't exist: create it
        Set s = ThisWorkbook.Sheets.Add( _
          after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        s.Name = sName      
        rng.Parent.Rows(1).Copy s.Range("a1") 'copy headers
    End If                  'needed a new sheet
    'return the first empty cell in column 1
    Set CopyTo = s.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End Function

Answer 2

' initialize variables
Dim CurrentValue As String
Dim ExistingValue As String
Dim ExistingLine As Integer

Dim CopyValue1 As String
Dim CopyValue2 As String
Dim CopyValue3 As String
Dim CopyValue4 As String
Dim CopyValue5 As String

' loop through rows
For i = 2 To 9 ' change 500 to number of rows

    ' set to first sheet and get data
    Sheets(1).Select
    CurrentValue = Cells(i, 1).Value
    CopyValue1 = Cells(i, 1).Value
    CopyValue2 = Cells(i, 2).Value
    CopyValue3 = Cells(i, 3).Value
    CopyValue4 = Cells(i, 4).Value
    CopyValue5 = Cells(i, 5).Value

    ' check if current value is same as existing
    If CurrentValue = ExistingValue Then

        ' add to line
        ExistingLine = ExistingLine + 1

        ' select sheet
        Sheets(Sheets.Count).Select

    Else

        ' reset line
        ExistingValue = CurrentValue
        ExistingLine = 2

        ' create new sheet
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = CurrentValue

        ' populate data
        Sheets(Sheets.Count).Select
        Cells(1, 1) = "PZ #"
        Cells(1, 2) = "Water EL"
        Cells(1, 3) = "TIP"
        Cells(1, 4) = "Pool"
        Cells(1, 5) = "Tail"

    End If

    ' populate data
    Cells(ExistingLine, 1) = CopyValue1
    Cells(ExistingLine, 2) = CopyValue2
    Cells(ExistingLine, 3) = CopyValue3
    Cells(ExistingLine, 4) = CopyValue4
    Cells(ExistingLine, 5) = CopyValue5

Next i