时间戳

首页 > 解决方案 > 宏的自动化/效率或宏概念的指导，以根据连续值移动某些单元格

excel - 宏的自动化/效率或宏概念的指导，以根据连续值移动某些单元格

问题描述

我有一个用于记录库存调整的电子表格。由于情况的原因，我还需要在另一个日志中列出这些数据，其中包括多个人所做的调整。有没有办法浓缩/改进我目前的方法？

我环顾了这个站点和其他站点，试图建立一些理解，尽可能复制代码，因为我绝不是中间用户。

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

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

标签： excelvba

解决方案

也许是这样的：

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变量（循环将负责实际的复制粘贴）。我认为最好在编程时尽量不要重复自己，我希望我的代码对你有意义。祝你好运。

推荐阅读