使用Button在Critera条件下复制Excel中的行

3 回答

• 1

  如果我在这里理解你就去吧 . 第一个子程序取自belisarius并适用于填充从2到100的每一行，然后我为每个按钮分配一个名为myMacro的宏 .

  Sub addButton()
  Dim btn As Button
  Application.ScreenUpdating = False
  ActiveSheet.Buttons.Delete
  Dim t As Range
  
  
  For i = 2 To 100 Step 1
     Set t = ActiveSheet.Range(Cells(i, 14), Cells(i, 14))
     Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
     With btn
       .OnAction = "btnS"
       .Caption = "Btn " & i
       .Name = i
       .OnAction = "myMacro"
     End With
  Next i
  
  Application.ScreenUpdating = True
  
  End Sub
  

  您可以根据需要多次运行它，因为它只会清除并重新制作99（红色 - 无法抗拒，实际上不是红色）按钮 .

  ---

  Sub myMacro()
  Dim sheet1, sheet2 As Worksheet
  Dim ButtonName As Integer
  Dim checkBlankRange As Range
  Dim answerRange As Range
  Dim pasteRow As Integer
  
  Set sheet1 = ActiveWorkbook.Sheets("Sheet1")
  Set sheet2 = ActiveWorkbook.Sheets("sheet2")
  Set checkBlankRange = sheet2.Range("A:A")
  
  ButtonName = Application.Caller
  
  Set answerRange = sheet1.Range("a" & ButtonName & ":m" & ButtonName)
  
  
          For Each cell In checkBlankRange
              If cell.Value = "" Then 'first empty cell
                      pasteRow = cell.row 'get the row number of the empty cell
                      sheet2.Range("a" & pasteRow & ":m" & pasteRow).Value2 = answerRange.Value2
                  Exit For
              End If
          Next cell
  
  answerRange.Delete Shift:=xlUp
  
  End Sub
  

  第二部分获取我们在sheet1上的第一个宏中设置的按钮名称，并根据“A：A”范围分配给sheet2上的第一个空行 . 最后，它删除与您选择的按钮对应的sheet1上的范围 .

  回复于 2024-04-25T12:03:09+08:00
• 1

  这是一个替代版本：

  Sub CreateButtons()
  
      Dim ws1 As Worksheet
      Dim ws2 As Worksheet
      Dim NCell As Range
      Dim i As Long
  
      Set ws1 = ActiveWorkbook.Sheets("Sheet1")
      Set ws2 = ActiveWorkbook.Sheets("Sheet2")
  
      ws1.Buttons.Delete
  
      For Each NCell In ws1.Range("N3:N102").Cells
          i = i + 1
          With ws1.Buttons.Add(NCell.Left, NCell.Top, NCell.Width, NCell.Height)
              .Name = "btn_MoveRow_" & Format(i, "00#")
              .Characters.Text = "Move Row"
              .OnAction = "MoveRow"
          End With
      Next NCell
  
  End Sub
  

  并且分配给按钮的MoveRow子例程：

  Sub MoveRow()
  
      Dim ws1 As Worksheet
      Dim ws2 As Worksheet
  
      Set ws1 = ActiveWorkbook.ActiveSheet
      Set ws2 = ActiveWorkbook.Sheets("Sheet2")
  
      With Intersect(ws1.Range("A:M"), ws1.Buttons(Application.Caller).TopLeftCell.EntireRow)
          ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, .Columns.Count).Value = .Value
          .Delete xlShiftUp
      End With
  
  End Sub
  

  回复于 2024-04-25T12:03:09+08:00
• 0

  JamesC和tigeravatar，

  非常感谢您的时间和精力，这些代码完全符合我的目标 .

  我设法让按钮创建，但无法移动和复制为我工作 . 但是你的解决方案都非常适合我想做的事情 .

  再次感谢！！

  回复于 2024-04-25T12:03:09+08:00