对于每个新条目，有条件地将选定的单元格从一个 sheet 复制到另一个

Question

我有两部作品sheet。在 sheet 1 上，我设置了一个宏来更改行的颜色并通过选择单元格分配 "TRUE" 值或通过再次选择单元格删除颜色和 "TRUE" 值。

Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer
Dim kod As Worksheet
Set kod = Worksheets("kodas")
  If Target.Column <> 12 Then Exit Sub
  If Target.Row = 1 Then Exit Sub
  If Target.Cells.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  If Target.Value <> "" Then
  Target.ClearContents
  Target.EntireRow.Interior.ColorIndex = 0
  Else
  Target.Value = "Taip"
  Target.EntireRow.Interior.ColorIndex = 4
  Target.EntireRow.Range(Cells(1), Cells(12)).Copy
  i = kod.Cells(2, 3)
  Sheets("Kodas2").Select
  ActiveSheet.Paste Destination:=Sheets("Kodas2").Cells(i, 1)
  End If
Application.EnableEvents = True
End Sub

*上面编辑的代码对我有用 - i = kod.Cells(2, 3) 是一个带有公式的单元格：count(table4[bla])+2 给出第一个空行号用于粘贴。

我现在需要在选择单元格时完成一些额外的操作 - 或者 - 在分配 "TRUE" 值时： (1) 将同一行的特定单元格复制并粘贴到 sheet 2 (2) 每行只完成一次此操作（无论单元格被选中多少次）- 也许锁定行会起作用？

颜色和 "True" 显示 sheet1 中的哪些行适合 table 以便在 sheet2 中继续工作，其中将添加更多数据。我基本上只想在输入时自动将 suitable 行汇集到下一个数据 sheet - 重要的是将值复制到新的 table ByVal 而不是 ByRef.

Answer 1

这个怎么样（不使用For...Next Loop）：

Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column <> 12 Then Exit Sub
  If Target.Row = 1 Then Exit Sub
  If Target.Cells.Count > 1 Then Exit Sub
  Application.EnableEvents = False
  If Target.Value <> "" Then
    Target.ClearContents
    Target.EntireRow.Interior.ColorIndex = 0
  Else
    Target.Value = "TRUE"
    Target.EntireRow.Interior.ColorIndex = 4
    Target.EntireRow.Copy
    DestLast = Sheets("Dest Sheet Name").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("Dest Sheet Name").Range("A" & DestLast).Paste
  End If
  Application.EnableEvents = True

End Sub

唯一的问题是，当您再次 select 单元格和 "turn off" 行时，它仍然会在您的 "further work" sheet.

上

对于每个新条目，有条件地将选定的单元格从一个 sheet 复制到另一个

Conditionally copy selected cells from one sheet to another once for each new entry

excel

vba