Question

我有一个包含500行（行）的电子表格我在下面使用VBA将信息从一个工作表移动到其他工作表，但它只更新指定的原始＆＃34;＆＃34; 5而不是其他行（例如第6行到第500行）任何一个可以持续VBA的帮助。我有四个工作表（Health RA，Task RA，Environment RA，Non-process RA），这些信息应该分发给。目前这个信息仅根据所做的选择分发给A5而不是A6 .......

Private Sub Decisionbtn_Click()
If Sheets("Baseline_RA").Cells(ActiveCell.Row, 14).Value = _
                                                 "Health risk assessment" Then
    Sheets("Health RA").Range("A5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 1)
    Sheets("Health RA").Range("B5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 2)
    Sheets("Health RA").Range("I5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 8)
    Sheets("Health RA").Range("O5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 11)
    Sheets("Health RA").Range("P5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 12)
    Sheets("Health RA").Range("Q5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 13)

    ElseIf Sheets("Baseline_RA").Cells(ActiveCell.Row, 14).Value = _
                                                 "Task risk assessment" Then
    Sheets("Task RA").Range("A5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 1)
    Sheets("Task RA").Range("B5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 2)
    Sheets("Task RA").Range("J5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 8)
    Sheets("Task RA").Range("P5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 11)
    Sheets("Task RA").Range("Q5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 12)
    Sheets("Task RA").Range("R5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 13)

    ElseIf Sheets("Baseline_RA").Cells(ActiveCell.Row, 14).Value = _
                                                  "Environment risk assessment" Then
    Sheets("Environment RA").Range("A5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 1)
    Sheets("Environment RA").Range("B5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 2)
    Sheets("Environment RA").Range("H5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 8)
    Sheets("Environment RA").Range("N5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 11)
    Sheets("Environment RA").Range("O5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 12)
    Sheets("Environment RA").Range("P5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 13)

    ElseIf Sheets("Baseline_RA").Cells(ActiveCell.Row, 14).Value = _
                                                  "Non-Process risk assessment" Then
    Sheets("Non-Process RA").Range("A5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 1)
    Sheets("Non-Process RA").Range("B5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 2)
    Sheets("Non-Process RA").Range("H5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 8)
    Sheets("Non-Process RA").Range("N5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 11)
    Sheets("Non-Process RA").Range("O5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 12)
    Sheets("Non-Process RA").Range("P5").Value = Sheets("Baseline_RA").Cells(ActiveCell.Row, 13)
End If

End Sub

Answer 1

未经测试但这样的事情应该有效

Private Sub Decisionbtn_Click()

    Dim shtDest As Worksheet, v As String, r As Range
    Dim rw As Range
    Dim rwStart As Long

    For Each r In Selection.Rows

        Debug.Print r.Row

        Set rw = r.EntireRow
        v = rw.Cells(14).Value

        Select Case v
            Case "Health risk assessment"
                Set shtDest = Sheets("Health RA")
            Case "Task risk assessment"
                Set shtDest = Sheets("Task RA")
            Case "Environment risk assessment"
                Set shtDest = Sheets("Environment RA")
            Case "Non-Process risk assessment"
                Set shtDest = Sheets("Health RA")
        End Select

        If shtDest Is Nothing Then Exit Sub 'or warn user?

        'Find next empty row (assuming every sheet will have a value in ColA
        '  if a row is populated) and copy values over
        With shtDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
            .Cells(1, "A").Value = rw.Cells(1).Value
            .Cells(1, "B").Value = rw.Cells(2).Value
            .Cells(1, "I").Value = rw.Cells(8).Value
            .Cells(1, "O").Value = rw.Cells(11).Value
            .Cells(1, "P").Value = rw.Cells(12).Value
            .Cells(1, "Q").Value = rw.Cells(13).Value
        End With

   Next r


End Sub

复制所选单元格时继续到其他行

1 个答案: