Question

我几天来一直在努力解决excel问题。我的Excel工作簿有两张标题为“Sheet1＆＃39;和＆＃39; Sheet2＆＃39;。

两个工作簿中的标题相同，范围为A2：M2。

我希望通过vba实现的是在每行N3，N4等的末尾引入一个按钮，该按钮将删除该行并将其粘贴到＆＃39; Sheet2＆＃39;下一行。我需要在行N3：N102中最多100个按钮。如果选择了宏按钮N10（例如），它将从＆＃39; Sheet1＆＃39;中复制内容A10：M10。进入＆＃39; Sheet2＆＃39;中的下一个可用行（在A2：M2之后）。并且还从＆＃39; Sheet1＆＃39;中删除A：10：M10行。同时保持100个按钮...

这对我想要实现的目标是否有意义？我迄今搜索过的所有编码都不包括按钮功能。

感谢您的帮助和时间。

Answer 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上的第一个宏中设置的按钮名称，并根据＆＃34; A：A＆＃34;分配给sheet2上的第一个空行。范围。最后，它会删除与您选择的按钮对应的sheet1上的范围。

Answer 2

以下是替代版本：

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

Answer 3

JamesC和tigeravatar，

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

我设法让按钮创建，但无法移动并复制为我工作。但是你的解决方案都非常适合我的目标。

再次感谢!!

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

3 个答案: