Update to existing Move data macro

[karl10220]

Hello! I previously came here for help to write a program to move data from one sheet to another with some complex movements. I am hopeful that by pasting the below code I can find help to make some modifications on a new program I am working on.

Previously the cost would take data from 1 cell, duplicate it 8 times, and in the horizontal row grab the data from the various cells and place it vertically (hence copying the part number 8 times and pasting 8 pieces of horizontal data vertically). This is a bit more complex as the information I need is in different columns.

For example,
I used to grab quantities in J, L, N, P, R, T, V, X. Now I need to grab quantities in P,R,T,V,X,Z,AB.
I used to grab corresponding prices in Y, AA, AC, AE, AG, AI, AK, AM. Now I need to grab corresponding prices in O, Q, S, U, W, Y, AA, AC.

I don't see that in my array of how to change it myself or I would have done that.

I'd also like to pull column G and paste it down 8 times because it applies to each iteration of quantity+price. I'd like to paste that in column U on receiving sheet, titled "New BPA".

Lastly, I do have Option Explicit active.

Thank you!

Sub New_Part_BPA2_Mod()

    Dim r As Long, q As Integer, lr As Long
    Dim lrData As Long, lcData As Long
    Dim wsData As Worksheet
    Dim wsOutput As Worksheet
    Dim rngData As Range, rngOut As Range
    Dim arrData As Variant, arrOut

    Set wsData = ThisWorkbook.Worksheets("New Parts") ' Change "Data" to the name of your data sheet
    Set wsOutput = ThisWorkbook.Worksheets("New BPA")
   
    With wsData
        lcData = .Cells(1, .Columns.Count).End(xlUp).Column
        lrData = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngData = .Range(.Cells(1, 1), .Cells(lrData, lcData))
        arrData = rngData.Value2
    End With
   
    With wsOutput
        lr = .Columns("E:R").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        If lr = 1 Then lr = 2
        .Range("E2:R" & lr).ClearContents
        Set rngOut = .Cells(2, "E")
    End With
       
    ' Column references based on 1 being Column E
    Dim outSupp As Long, outItem As Long, outPrice As Long, outStore As Long, outQty As Long
    outSupp = 1
    outItem = 8
    outPrice = 10
    outStore = 13
    outQty = 14
   
    ReDim arrOut(1 To lrData * 8, 1 To outQty)
    lr = 0
    For r = 2 To UBound(arrData)                                        ' Loop through all items in data sheet
        For q = 1 To 8                                                  ' Loop through all quantities
            lr = lr + 1                                                 ' Increment row in output sheet
            arrOut(lr, outSupp) = arrData(r, 2)                         ' Supplier
            arrOut(lr, outItem) = arrData(r, 3)                         ' Item
            arrOut(lr, outPrice) = Round(arrData(r, 26 + q * 2), 4)    ' Price
            arrOut(lr, outStore) = arrData(r, 1)                        ' Store
            arrOut(lr, outQty) = arrData(r, 11 + q * 2)                 ' Quantity
        Next q
    Next r
   
    rngOut.Resize(lr, UBound(arrOut, 2)).Value2 = arrOut
End Sub

 

[karl10220]

That's just bizarre the code runs perfectly for me.
When it errors out can you hover of outGoods and tell me what value it comes up with ?
(do lr and r as well but if they were the problem it shouldn't have gotten to that line.)

The only other thing is if you could share the workbook via a sharing platform (Dropbox, Google drive etc) with permission to anyone with the link.
Just make sure that the issue still exists in your sample workbook.

I am not sure what happened, but I just copied and pasted and it now works! I even added another variable into it following your notes and got that to work! Thank you!!

 

[Alex Blakenburg]

You're welcome. Glad I could help. Great to hear that you are able to make changes.