关于宏的自动化/效率或宏概念的指南，用于基于连续的值移动某些单元格

Question

我有一个电子表格，用于记录库存调整。视情况而定，我还需要在另一个日志中列出此数据，其中包括多个人所做的调整。有没有一种方法可以压缩/改进我目前使用的方法？

我到处都是这个网站，其他人则试图建立一些了解，并尽可能复制代码，因为我绝不是中级用户。

Option Explicit
Sub moveInput()

'Worksheets("test").Range("A3:G3").Copy
'Workbooks("Book2").Worksheets("Sheet7").Activate
'Range("A1").End(xlDown).Offset(1, 0).Select

Workbooks("Book1").Worksheets("test").Range("A3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("B3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("B1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("C3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("C1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("D3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("D1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("E3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("J1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("F3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("M1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks("Book1").Worksheets("test").Range("G3").Copy
Workbooks("Book2").Worksheets("Sheet7").Range("Q1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

End Sub

Option Explicit
Sub moveInput_2()
'*****************'
'Declare Variables'
'*****************'
Dim lastRow As Long
Dim wB1 As Workbook
Dim wB2 As Workbook
Dim wsTest As Worksheet
Dim ws7 As Worksheet
Dim i As Integer
'*************'
'Set Variables'
'*************'
Set wB2 = Workbooks("Book2.xlsm")
Set ws7 = wB2.Sheets("Sheet7")
Set wB1 = Workbooks("Book1.xlsm")
Set wsTest = wB1.Sheets("test")
i = 1
'***********************'
'Find Last Row For Input'
'***********************'
'On Error GoTo errlastrow
With ws7
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastRow = 1
    End If
End With
'On Error GoTo 0
'****************************'
'Find Rows That Need Transfer'
'****************************'
'On Error GoTo errinput
With wsTest
    For i = 1 To 250
        If .Cells(i, 6).Value > 300 Then
            wB2.ws7.Range(lastRow, 1).Value = wB1.wsTest.Range(i, 1).Value 'Error pops up here, object doesn't support this property or method
'I've tried switching them around, including wb, sheet, range and nothing.
            ws7.Range("lastrow, 2").Value = wsTest.Range(i, 2).Value
            ws7.Range("lastrow, 1").Value = wsTest.Range(i, 3).Value
            ws7.Range("lastrow, 1").Value = wsTest.Range(i, 4).Value
            ws7.Range("lastrow, 10").Value = wsTest.Range(i, 5).Value
            ws7.Range("lastrow, 13").Value = wsTest.Range(i, 6).Value
            ws7.Range("lastrow, 17").Value = wsTest.Range(i, 7).Value
        End If
    Next i
    lastRow = lastRow + 1
End With
'On Error GoTo 0
Exit Sub
'**************'
'Error Handling'
'**************'
'errlastrow:
'MsgBox "Could not find last row, check dataset!" & Err.Description
'End
'errinput:
'MsgBox "No data to input" & Err.Description
'End
End Sub

我的最终目标是使宏（最好分配给按钮）将标识我的成本值超过一定金额的行，然后从该行复制并粘贴某些单元格到主日志中。行和列将不同。在打开单独的工作簿时可以检查活动用户，并在有活动时取消操作，这也将有所帮助，但不是必须的（我可以环顾四周）。

Answer 1

我的建议是停止使用剪贴板。如果在宏运行时使用剪贴板，则可能会导致不良结果。除此之外，您的代码还不错。很简单。

Sub moveInput()

'Worksheets("test").Range("A3:G3").Copy
'Workbooks("Book2").Worksheets("Sheet7").Activate
'Range("A1").End(xlDown).Offset(1, 0).Select



Workbooks("Book2").Worksheets("Sheet7").Range("A1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("A3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("B1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("B3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("C1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("C3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("D1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("D3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("J1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("E3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("M1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("F3").Value
Workbooks("Book2").Worksheets("Sheet7").Range("Q1").End(xlDown).Offset(1, 0).Value = Workbooks("Book1").Worksheets("test").Range("G3").Value

End Sub

Answer 2

也许是这样的：

Option Explicit

Sub MoveInput()
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("test")

    Dim destinationSheet As Worksheet
    Set destinationSheet = ThisWorkbook.Worksheets("Sheet7")

    Dim copyPasteMap As Variant ' (SourceColumn, DestinationColumn), (SourceColumn, DestinationColumn), etc.
    copyPasteMap = Array(Array("A", "A"), _
                        Array("B", "B"), _
                        Array("C", "C"), _
                        Array("D", "D"), _
                        Array("E", "J"), _
                        Array("F", "M"), _
                        Array("G", "Q") _
                        )

    Dim lastRowOnDestinationSheet As Long
    lastRowOnDestinationSheet = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row

    Dim index As Long
    For index = LBound(copyPasteMap) To UBound(copyPasteMap)
        Dim sourceColumnLetter As String
        sourceColumnLetter = copyPasteMap(index)(0)

        Dim destinationColumnLetter As String
        destinationColumnLetter = copyPasteMap(index)(1)

        destinationSheet.Cells(lastRowOnDestinationSheet + 1, destinationColumnLetter).Value = sourceSheet.Cells(3, sourceColumnLetter).Value
    Next index
End Sub

copyPasteMap基本上只是2个项目的数组。每个2个项目的数组都包含源列（我们要从中复制的列）和目标列（我们要粘贴到的列）。

我使用Array()函数是因为它相对方便，但替代方法可能包括创建自定义类型/类或使用某种关联的键值结构。

这也意味着，如果您需要复制和粘贴更多的列，则只需更新copyPasteMap变量（循环将负责实际的复制粘贴）。我认为最好不要在编程时重复自己，我希望我的代码对您有意义。祝你好运。

Answer 3

因此，如果有人感兴趣，这就是我要讲的内容。我唯一的问题是，即使过滤，它也会写入所有内容。小障碍，我以后可以担心。

Option Explicit
Sub moveInput_2()
'*****************'
'Declare Variables'
'*****************'
Dim lastRow As Long
Dim wB1 As Workbook
Dim wB2 As Workbook
Dim wsTest As Worksheet
Dim ws7 As Worksheet
Dim i As Long
Dim j As Long
'*************'
'Set Variables'
'*************'
Set wB2 = Workbooks("Book2")
Set ws7 = wB2.Sheets("Sheet7")
Set wB1 = Workbooks("Book1")
Set wsTest = wB1.Sheets("test")
i = 1
j = 1
'***********************'
'Find Last Row For Input'
'***********************'
On Error GoTo errlastrow
With ws7
ws7.Activate
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastRow = 1
    End If
End With
On Error GoTo 0
'****************************'
'Find Rows That Need Transfer'
'****************************'
On Error GoTo errinput
With wsTest
wsTest.Activate
    Range("A1:G1").AutoFilter field:=6, Criteria1:=">300", Operator:=xlFilterValues
        For i = 2 To 250
            ws7.Cells(lastRow, "A").Offset(1, 0).Value = wsTest.Cells(i, 1).Value
            ws7.Cells(lastRow, "B").Offset(1, 0).Value = wsTest.Cells(i, 2).Value
            ws7.Cells(lastRow, "C").Offset(1, 0).Value = wsTest.Cells(i, 3).Value
            ws7.Cells(lastRow, "D").Offset(1, 0).Value = wsTest.Cells(i, 4).Value
            ws7.Cells(lastRow, "J").Offset(1, 0).Value = wsTest.Cells(i, 5).Value
            ws7.Cells(lastRow, "M").Offset(1, 0).Value = wsTest.Cells(i, 6).Value
            ws7.Cells(lastRow, "Q").Offset(1, 0).Value = wsTest.Cells(i, 7).Value
            lastRow = lastRow + 1
            i = i + 1
        Next i
End With
On Error GoTo 0
Exit Sub
'**************'
'Error Handling'
'**************'
errlastrow:
MsgBox "Could not find last row, check dataset!" & Err.Description
End
errinput:
MsgBox "No data to input!" & Err.Description
End
End Sub

感谢所有回答的人。