Руководство по автоматизации / эффективности макроса или концепции макроса для перемещения определенных ячеек на основе значения в строке

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

Может быть, что-то вроде этого:

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 2

Так вот к чему я пришел, если кому-то было интересно. Моя единственная проблема в том, что он пишет все, даже когда фильтруется. Небольшая загвоздка, я могу об этом побеспокоиться позже.

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

Спасибо всем, кто ответил.

Answer 3

Мой совет - прекратить использование буфера обмена.Если вы используете буфер обмена во время работы макроса, вы можете получить нежелательные результаты.Кроме того, ваш код не плохой.Это довольно просто.

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