0

我有一个带有渗压计数据的电子表格。我使用的那个更大，我们每半年左右更新一次，但这里是要点：

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 之旅。

有没有人可以使用任何有用的建议/代码？

4

2 回答 2

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
于 2013-08-26T21:38:09.843 回答
0 
' 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
于 2013-08-26T21:42:55.710 回答