Проблемы при разработке кода VBA для копирования и определенных ячеек и вставки их в зависимости, если есть значение в другой ячейке

Question

Все, я работаю над созданием кода VBA, который сохраняет данные в форме одним нажатием кнопки.У меня есть отработанный код, но в настоящее время его отправка занимает слишком много времени, поэтому я работаю над тем, чтобы сократить его.Это фрагмент исходного кода.

Sub TransferDeliveryInfoB13()

Sheets("Parts In-Out Form").Select

Range("d9").Select

If ActiveCell.Value = ("In") And (Sheets("Parts In-Out Form").Range("b13") > 0) Then

    'Copy Part Number'
    Dim LastRow As Long
    LastRow = Sheets("Deliveries").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

    Sheets("Parts In-Out Form").Range("b13").Copy
    Sheets("Deliveries").Cells(LastRow, 3).PasteSpecial xlPasteValues

    'Copy Back Ordered Quanity'
    Sheets("Parts In-Out Form").Range("c13").Copy
    Sheets("Deliveries").Cells(LastRow, 9).PasteSpecial xlPasteValues

    'Copy Back Order ETA
    Sheets("Parts In-Out Form").Range("c9").Copy
    Sheets("Deliveries").Cells(LastRow, 10).PasteSpecial xlPasteValues

    'Copy Quanity'
    Sheets("Parts In-Out Form").Range("d13").Copy
    Sheets("Deliveries").Cells(LastRow, 4).PasteSpecial xlPasteValues

    'Copy Employee Number
    Sheets("Parts In-Out Form").Range("f9").Copy
    Sheets("Deliveries").Cells(LastRow, 5).PasteSpecial xlPasteValues

    'Copy BOL Number
    Sheets("Parts In-Out Form").Range("h9").Copy
    Sheets("Deliveries").Cells(LastRow, 2).PasteSpecial xlPasteValues

    'Copy PO Number
    Sheets("Parts In-Out Form").Range("f12").Copy
    Sheets("Deliveries").Cells(LastRow, 8).PasteSpecial xlPasteValues

    'Copying Whether or Not Back Order Delivery
    Sheets("Parts In-Out Form").Range("h12").Copy
    Sheets("Deliveries").Cells(LastRow, 12).PasteSpecial xlPasteValues

    'Copying Date
    Sheets("Parts In-Out Form").Range("b9").Copy
    Sheets("Deliveries").Cells(LastRow, 1).PasteSpecial xlPasteValues

    Call TransferDeliveryInfoB14

    Else

        Sheets("Deliveries").Select
        ActiveSheet.Protect ("mustache")

        Sheets("Parts In-Out Form").Range("B9,D9,F9,H9,C9,F12,B12:B42,C12:C42,D12:D42,H12").ClearContents

    End If

 End Sub
 Sub TransferDeliveryInfoB14()

Sheets("Parts In-Out Form").Select

Range("d9").Select

If ActiveCell.Value = ("In") And (Sheets("Parts In-Out Form").Range("b14") > 0) Then

    'Copy Part Number'
    Dim LastRow As Long
    LastRow = Sheets("Deliveries").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

    Sheets("Parts In-Out Form").Range("b14").Copy
    Sheets("Deliveries").Cells(LastRow, 3).PasteSpecial xlPasteValues

    'Copy Back Ordered Quanity'
    Sheets("Parts In-Out Form").Range("c14").Copy
    Sheets("Deliveries").Cells(LastRow, 9).PasteSpecial xlPasteValues

    'Copy Back Order ETA
    Sheets("Parts In-Out Form").Range("c9").Copy
    Sheets("Deliveries").Cells(LastRow, 10).PasteSpecial xlPasteValues

    'Copy Quanity'
    Sheets("Parts In-Out Form").Range("d14").Copy
    Sheets("Deliveries").Cells(LastRow, 4).PasteSpecial xlPasteValues

    'Copy Employee Number
    Sheets("Parts In-Out Form").Range("f9").Copy
    Sheets("Deliveries").Cells(LastRow, 5).PasteSpecial xlPasteValues

    'Copy BOL Number
    Sheets("Parts In-Out Form").Range("h9").Copy
    Sheets("Deliveries").Cells(LastRow, 2).PasteSpecial xlPasteValues

    'Copy PO Number
    Sheets("Parts In-Out Form").Range("f12").Copy
    Sheets("Deliveries").Cells(LastRow, 8).PasteSpecial xlPasteValues

    'Copying Whether or Not Back Order Delivery
    Sheets("Parts In-Out Form").Range("h12").Copy
    Sheets("Deliveries").Cells(LastRow, 12).PasteSpecial xlPasteValues

    'Copying Date
    Sheets("Parts In-Out Form").Range("b9").Copy
    Sheets("Deliveries").Cells(LastRow, 1).PasteSpecial xlPasteValues

    Call TransferDeliveryInfoB15

    Else

        Sheets("Deliveries").Select
        ActiveSheet.Protect ("mustache")

        Sheets("Parts In-Out Form").Range("B9,D9,F9,H9,C9,F12,B12:B42,C12:C42,D12:D42,H12").ClearContents

    End If

 End Sub

Я пытаюсь сделать вместо миллиона операторов if then для каждой ячейки, чтобы сжать ее в один код, где она будет копировать и вставлять номер деталии количество.и если есть значение, оно скопирует бол, дату, номер сотрудника в соответствующем столбце в строке.вот что у меня есть.

Sub TransferDeliveryInfoB12()

'make sure to unlock sheet
    Sheets("Deliveries").Select
    ActiveSheet.Unprotect ("mustache")

Sheets("Parts In-Out Form").Select

Range("d9").Select

If ActiveCell.Value = ("In") Then

    Dim LastRow As Long
    LastRow = Sheets("Deliveries").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

    'Copy Parts Number
    Sheets("Parts In-Out Form").Range("b12:b42").Copy
    Sheets("Deliveries").Cells(LastRow, 3).PasteSpecial xlPasteValues

    'Copy Back Ordered Quanity
    Sheets("Parts In-Out Form").Range("c12:c42").Copy
    Sheets("Deliveries").Cells(LastRow, 9).PasteSpecial xlPasteValues

    'Copy Parts Quanity
    Sheets("Parts In-Out Form").Range("b12:b42").Copy
    Sheets("Deliveries").Cells(LastRow, 4).PasteSpecial xlPasteValues

Я не совсем уверен, куда идти с этой точки.Заранее благодарим за все указания и помощь.

Answer 1

Разобрался.Вот чем я закончил.

`
Sub TransferDeliveryInfo ()

 Application.EnableEvents = False
 Application.ScreenUpdating = False

'make sure to unlock sheet
    Sheets("Deliveries").Select
    ActiveSheet.Unprotect ("mustache")

    Dim n As Integer
    Dim j As Integer
    n = 11
    Do Until n = 43
        n = n + 1

 If Sheets("Parts In-Out Form").Range("b" & n) > 0 Then

    'Copy Part Number'
    Dim LastRow As Long
    LastRow = Sheets("Deliveries").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

    Sheets("Deliveries").Cells(LastRow, 3) = Sheets("Parts In-Out Form").Range("b" & n)

    'Copy Back Ordered Quanity'
    Sheets("Deliveries").Cells(LastRow, 9) = Sheets("Parts In-Out Form").Range("d" & n)

    'Copy Back Order ETA
    Sheets("Deliveries").Cells(LastRow, 10) = Sheets("Parts In-Out Form").Range("e" & n)

    'Copy Quanity'
    Sheets("Deliveries").Cells(LastRow, 4) = Sheets("Parts In-Out Form").Range("c" & n)

    'Copy Employee Number
    Sheets("Deliveries").Cells(LastRow, 5) = Sheets("Parts In-Out Form").Range("g9")

    'Copy BOL Number
    Sheets("Deliveries").Cells(LastRow, 2) = Sheets("Parts In-Out Form").Range("i9")

    'Copy PO Number
    Sheets("Deliveries").Cells(LastRow, 8) = Sheets("Parts In-Out Form").Range("g12")

    'Copying Whether or Not Back Order Delivery
    Sheets("Deliveries").Cells(LastRow, 12) = Sheets("Parts In-Out Form").Range("i12")

    'Copying Date
    Sheets("Deliveries").Cells(LastRow, 1) = Sheets("Parts In-Out Form").Range("b9")

    Else

    Sheets("Deliveries").Select
    ActiveSheet.Protect ("mustache")

    Sheets("Parts In-Out Form").Range("B9,D9,G9,I9,G12,I12,B12:B42,C12:C42,D12:D42,E12:E42").ClearContents

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    End If

    Loop

 End Sub

`

Answer 2

Ваш код действительно должен быть сведен к чему-то вроде этого - пара циклов повторяется сколько угодно раз для ваших значений в столбце B - хотя вам придется добавить некоторые сложные вещи со вторым массивом (arr2) потому что это не согласуется с вашими подпрограммами - извините за короткий пример:

Option Explicit
Dim sht As Worksheet, destsht As Worksheet
Dim i As Long, j As Long
Dim arr As Variant, arr2 As Variant
Sub TransferDeliveryInfoB13()

    Set sht = Sheets("Parts In-Out Form")
    Set destsht = Sheets("Deliveries")

    arr = Array(3, 9, 10, 4, 5, 2, 8, 12, 1)
    arr2 = Array("B13", "C13", "C9", "D13", "F9", "H9", "F12", "H12", "B9")

    Dim LastRow As Long
    LastRow = destsht.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
    j = 0

    For i = 13 To 15
        If sht.Range("D9").Value = "In" And sht.Range("B" & i) > 0 Then
            For j = 0 To UBound(arr)
                destsht.Cells(LastRow, arr(j)).Value = sht.Range(arr2(j)).Value
            Next j
        Else
            destsht.Protect ("mustache")
            sht.Range("B9,D9,F9,H9,C9,F12,B12:B42,C12:C42,D12:D42,H12").ClearContents
        End If
    Next i

 End Sub