Trouble developing vba code to copy and certain cells and paste them dependent if there is a value in another cell

Question

All, I am working on creating a vba code that saves data on a form with a click of a button. I have the code worked out but currently it takes too long to submit so I am working on trying to shorten it up. This is a snippet of the original code.

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

What I am attempting to do is instead of a million if then statements for each cell to compact that into one code where it will copy and paste the parts number, and quanity. and if there is there a value it will copy the bol, date, employee number in the corresponding column in the row. here's what I have so far.

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

I am not really sure where to go from this point. Thanks in advance for all direction and help given.

Start by [avoiding activate and select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — cybernetic.nomad, Feb 20 '19 at 22:17
Whs, also every time you ask excel to look up by text that slows it down. Set mysheet=Sheets("somesheet") then reuse mysheet. Also dont copy and paste, say somecell.formula = othercell.value — ajd, Feb 20 '19 at 22:49

score 0 · Answer 1 · answered Feb 20 '19 at 22:58

Your code should really be condensed down to something like this - a couple loops iterating however many times you need to for your values in column B - although, you'd have to add some tricky stuff with the second array (arr2) because that's not consistent throughout your subroutines - sorry for the short example:

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

score 0 · Answer 2 · answered Feb 21 '19 at 19:27

Figured it out. Here is what I ended up with.

`
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

`

Trouble developing vba code to copy and certain cells and paste them dependent if there is a value in another cell

2 Answers2