Help with VBA Code to Populate Another Worksheet

[leigh123]

Hi, I am fairly new to VBA and am trying to run a VBA code where it will take a list of information and populate multiple worksheets based on a specific part number. Below is what I have so far...

Basically, I have a list of data that I have received from suppliers and am wanting to input the data into a worksheet per part number. One issue that I'm running into is that there are multiple rows that contain the same part number, but with different quantities (I would like excel to take the lines with the same part numbers and export that data onto another excel per part number). Right now, my code is taking each row and giving it it's own worksheet no matter what the part number is. There are multiple lines that have the same part number, but with different qtys, and I would like it to capture the different unit prices based on the different qtys.

1. The ultimate goal that I want this code to do is to take the list of data, sort it by part number, populate one worksheet per part number and include the information for the rows that have the same part number.
2. Since there are multiple rows that have the same part number, there are some excel lines that will require multiple lines to be populated in the new worksheet and some excel lines that will only require one cell to be populated to the new worksheet.
For the lines that will only need one input to the new worksheet, " 'ITEMS THAT WILL POPULATE ONLY ONCE BASED SAME PART NUMBER", I would like it to capture the information from the last row of the same part number.
For the lines that will have multiple line inputs, "'ITEMS THAT WILL POPULATE MULTIPLE LINES BASED ON SAME PART NUMBER", I would like it to keep populating down the rows with the same part number information. For instance, under 'ITEMS THAT WILL POPULATE MULTIPLE LINES BASED ON SAME PART NUMBER under Population to New Worksheet, if there are rows on the data worksheet that have the same part number, it will start populating at A7 and keep populating it down to A8 and so on.

Again, I am very new to VBA and would appreciate any help on this problem! Thank you!

wSrc= worksheet data is being pulled from
sTrg= data transferring to this worksheet

ub BidSummary()
Dim wSrc As Workbook
Dim sSrc As Worksheet
Dim wTrg As Workbook
Dim sTrg As Worksheet
Dim r As Long
Dim m As Long
Application.ScreenUpdating = False
Set wSrc = ThisWorkbook
Set sSrc = wSrc.Worksheets("Bid")
m = sSrc.Range("A" & sSrc.Rows.Count).End(xlUp).Row
For r = 3 To m

Select Case sSrc.Range("D" & r).Value
Case "Bid"
wSrc.Worksheets("Bid Summary").Copy
End Select
Set wTrg = ActiveWorkbook
Set sTrg = wTrg.Worksheets(1)

'VARIABLE ASSIGNMENTS

'General Part Object Assignments
Dim part_number As String
Dim description As String
Dim RFP_Qty As Integer
Dim UOM As String
Dim buyer As String

'Vendor 1 Object Assignments
Dim lead_time1 As String
Dim quote_date1 As Integer
Dim Vendor_Name1 As String
Dim Vendor_Contact1 As String
Dim Vendor_Phone1 As Integer
Dim V1_unit_price As Integer

'Vendor 2 Object Assignments
Dim lead_time2 As String
Dim quote_date2 As Integer
Dim Vendor_Name2 As String
Dim Vendor_Contact2 As String
Dim Vendor_Phone2 As Integer
Dim v2_unit_price As Integer



'ITEMS THAT WILL POPULATE ONLY ONCE BASED SAME PART NUMBER

'Buyer
buyer = sSrc.Range("F" & r).Value

'Vendor 1 Column Assignments
lead_time1 = sSrc.Range("P" & r).Value
quote_date1 = sSrc.Range("O" & r).Value
Vendor_Name1 = sSrc.Range("I" & r).Value
Vendor_Contact1 = sSrc.Range("K" & r).Value
Vendor_Phone1 = sSrc.Range("L" & r).Value

'Vendor 2 Column Assignmens
lead_time2 -sSrc.Range("Y" & r).Value
quote_date2 = sSrc.Range("X" & r).Value
Vendor_Name2 = sSrc.Range("R" & r).Value
Vendor_Contact2 = sSrc.Range("T" & r).Value
Vendor_Phone2 = sSrc.Range("U" & r).Value


'ITEMS THAT WILL POPULATE MULTIPLE LINES BASED ON SAME PART NUMBER

'General Part Column Assignments
part_number = sSrc.Range("B" & r).Value
description = sSrc.Range("C" & r).Value
RFP_Qty = sSrc.Range("G" & r).Value
UOM = sSrc.Range("H" & r).Value
V1_unit_price = sSrc.Range("N" & r).Value
v2_unit_price = sSrc.Range("W" & r).Value




'POPULATION TO NEW WORKSHEET


'ITEMS THAT WILL POPULATE ONLY ONCE BASED SAME PART NUMBER

'PART INFORMATION
'Buyer
sTrg.Range("C4").Value = sSrc.Range("F" & r).Value

'VENDOR INFORMATION
'Vendor Name
sTrg.Range("G3").Value = sSrc.Range("I" & r).Value
sTrg.Range("K3").Value = sSrc.Range("R" & r).Value

' Vendor Contact
sTrg.Range("G4").Value = sSrc.Range("K" & r).Value
sTrg.Range("K4").Value = sSrc.Range("T" & r).Value

' Vendor Phone Number
sTrg.Range("G5").Value = sSrc.Range("L" & r).Value
sTrg.Range("K5").Value = sSrc.Range("U" & r).Value

' Vendor #1 Lead Time
sTrg.Range("J23").Value = sSrc.Range("P" & r).Value
' Vendor #1 Date of Quote
sTrg.Range("J24").Value = sSrc.Range("O" & r).Value
' Vendor #2 Lead Time
sTrg.Range("N23").Value = sSrc.Range("Y" & r).Value
' Vendor #2 Date of Quote
sTrg.Range("N24").Value = sSrc.Range("X" & r).Value



'ITEMS THAT WILL POPULATE MULTIPLE LINES BASED ON SAME PART NUMBER

'PART INORMATION

' Part Number (CY 2023)
sTrsTrg.Range("A7").Value = Src.Range("B" & r).Value
' Part Description (CY 2023)
sTrg.Range("F7").Value = sSrc.Range("C" & r).Value

' Qty
sTrg.Range("F7").Value = sSrc.Range("C" & r).Value
' RFP Qty (CY 2023)
sTrg.Range("D7").Value = sSrc.Range("G" & r).Value
' UOM
sTrg.Range("E7").Value = sSrc.Range("H" & r).Value

'PRICING INORMATION
' Vendor #1 Unit Prices
sTrg.Range("G7").Value = sSrc.Range("N" & r).Value
' Vendor #2 Unit Prices
sTrg.Range("K7").Value = sSrc.Range("W" & r).Value



' Optional: save and close the review workbook
wTrg.SaveAs Filename:=wSrc.Path & "\" & sSrc.Range("F" & r).Value & "_" & sSrc.Range("B" & r).Value & " " & "Qty" & " " & sSrc.Range("G" & r).Value & " " & sSrc.Range("AV" & r).Value & " " & "Bid Summary" & " " & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
wTrg.Close SaveChanges:=False
Next r
Application.ScreenUpdating = True
End Sub

 

[aaewalsh]

Try this:

Public Sub BidSummary()
    Dim wSrc As Workbook
    Dim sSrc As Worksheet
    Dim wTrg As Workbook
    Dim sTrg As Worksheet
    Dim r As Long
    Dim m As Long
    Dim lastRow As Long
    Dim partNumber As String
    Dim nextRow As Long
    Dim dataArray() As Variant
    Application.ScreenUpdating = False
    Set wSrc = ThisWorkbook
    Set sSrc = wSrc.Worksheets("Bid")
    m = sSrc.Range("A" & sSrc.Rows.Count).End(xlUp).Row
    'Create array to store data for each part number
    dataArray = sSrc.Range("A3:N" & m).Value
    lastRow = 0
    partNumber = dataArray(lastRow, 1)
    nextRow = 7
    For r = 0 To UBound(dataArray, 1)
        If dataArray(r, 3) = "Bid" Then
            'Check if current row is for the same part number
            If dataArray(r, 1) <> partNumber Then
                partNumber = dataArray(r, 1)
                Set wTrg = Workbooks.Add
                Set sTrg = wTrg.ActiveSheet
                lastRow = r
                'Code for processing data for last row of same part number
                'Buyer
                sTrg.Range("C4").Value = dataArray(lastRow, 6)
                'Vendor 1 Column Assignments
                sTrg.Range("G3").Value = dataArray(lastRow, 9)
                sTrg.Range("G4").Value = dataArray(lastRow, 11)
                sTrg.Range("G5").Value = dataArray(lastRow, 12)
                sTrg.Range("J23").Value = dataArray(lastRow, 16)
                sTrg.Range("J24").Value = dataArray(lastRow, 15)
                'Vendor 2 Column Assignmens
                sTrg.Range("K3").Value = dataArray(lastRow, 18)
                sTrg.Range("K4").Value = dataArray(lastRow, 20)
                sTrg.Range("K5").Value = dataArray(lastRow, 21)
                sTrg.Range("Q23").Value = dataArray(lastRow, 25)
                sTrg.Range("Q24").Value = dataArray(lastRow, 24)
                nextRow = 7
            End If
            'Code for populating data for multiple lines of same part number
            'General Part Column Assignments
            sTrg.Range("A" & nextRow).Value = dataArray(r, 1)
            sTrg.Range("B" & nextRow).Value = dataArray(r, 2)
            sTrg.Range("C" & nextRow).Value = dataArray(r, 6)
            sTrg.Range("D" & nextRow).Value = dataArray(r, 7)
            sTrg.Range("E" & nextRow).Value = dataArray(r, 8)
            'Vendor 1 Column Assignments
            sTrg.Range("F" & nextRow).Value = dataArray(r, 15)
            sTrg.Range("G" & nextRow).Value = dataArray(r, 16)
            'Vendor 2 Column Assignmens
            sTrg.Range("H" & nextRow).Value = dataArray(r, 24)
            sTrg.Range("I" & nextRow).Value = dataArray(r, 25)
            nextRow = nextRow + 1
        End If
    Next r
    Application.ScreenUpdating = True
End Sub