Macro - new supplier worksheets created

[richardjshaffer]

Please, hope someone can help, I posted this a few days however have now been able to attach an example file on the link below.

What we are trying to achieve is a macro which creates a new worksheet for every unique supplier listed in the SUMMARY worksheet.

So the SUMMARY worksheet is populated which lots of data with many different suppliers listed down in column B, and the relevant data in the other columns - what the macro needs to do is use the TEMPLATE worksheet and create a new worksheet for each different supplier (with the worksheet created named by the supplier number) and the relevant fields in each new worksheet filled in.

Here is the example file which just shows 1 worksheet created (F1111) for the only supplier mentioned in the SUMMARY worksheet

http://www.4shared.com/file/4B_nimp5...te__RS_v3.html

many thanks, hope someone can help please,

Richard

 

[sijpie]

I get an invalid link on yourr link

So you want to run the macro once, on a regular basis or whenever a new line has been added to check for new suppliers?
How many suppliers are there (can there be in future)? If large number that it will be quicker to store the values in a memory table, if small then we can just loop through the table in the sheet (bit slower).

1. You create an array to hold the supplier names
2. Another array to hold the sheet names (assuming you want to check if the supplier has a sheet, else new)
3. Next load the supplier into the first array
4. then loop through the sheet names and load them into the 2nd array
5. Then loop through the 1st array and check if name appears in 2nd array.

 

[richardjshaffer]

Hi,

thanks for your post -

yes, we want to run it once to create new worksheets for every supplier there is. Sorry, I'm not so familiar with creating macros nor this sharing site, not sure why the link stopped working, I've tried again with another version of the file, please can you try this link:

http://www.4shared.com/account/dir/OVDFSDXz/_online.html?rnd=50

If is asks for sign in the user is richardjshaffer@hotmail.com, password richardjshaffer

hope this works, thanks for you help,

thanks

 

[sijpie]

I'm not ignoring this, just working on a macro.

 

[sijpie]

On the suppliers sheets, can a PO number appear more than once?

or alternatively can the rows on the supplier sheets 11:xxxx be deleted and recreated from the summary sheet?

saves a lot of coding, serching if records already exist on the sheet

 

[richardjshaffer]

Hi,

thanks for looking at this for us.

There could be the same PO listed a number of times, though the UPC number would be unique.

Hope this helps, if there is anything else I can be clearer on just say,

thanks,

Richard

 

[sijpie]

OK, this code should work fine.

It first loads the list on summary sheet in an array, with the columns in the order that is required for the output sheets. This is done to write very quickly to the output sheets. next it checks to see if new supplier pages need to be created.
Then it runs through each of the line items and checks for the PO number if it appears on the supplier sheet. If it exists then the UPC number is checked to ensure we don't write a duplicate line. If the line is not a duplicate it gets written to the output sheet.

Option Explicit
Sub CheckAndCopyRTM()
'   subroutine to check through SUMMARY sheet for all
'   RTMs to be copied to Supplier sheets. Create
'   Supplier sheet if required
'
    Dim RTM() As Variant, SupplshNames() As String, SupplNames As Variant
    Dim SupplCount As Long, lElement As Long, bFlag As Boolean
    Dim arChk, rPO As Range, rUPC As Range, lPO As Long, lUPC As Long
    
    
    SupplCount = Sheets("SUMMARY").Range("B6").End(xlDown).Row - 6
    If SupplCount > 60000 Then '    sheet is empty
        MsgBox "No RTMs on sheet."
        Exit Sub
    End If
    ReDim RTM(1 To SupplCount, 1 To 13)
'    ReDim SupplNames(1 To SupplCount)
'    With Application
'        av = .Index(Cells, [row(1:10)], Array(1, 3, 6, 2))
'    End With
    
    Sheets("SUMMARY").Activate
    
    With Application
                        ' copy SUMMARY data into RTM array, with columns in same order as
                        ' required for output in individual supplier sheets
        lElement = SupplCount + 6
        RTM = .Index(Cells, Evaluate("row(7:" & lElement & ")"), Array(6, 3, 4, 5, 9, 8, 10, 11, 12, 13, 14, 16))
    End With
    
    SupplNames = Range("B7:B" & SupplCount + 6) ' set SupplNames to supplier names
   
    StoreSheetNamesInArray SupplshNames     ' store the sheet names of workbook
    
    
    For lElement = LBound(SupplNames) To UBound(SupplNames)
    '   check for new names
        arChk = Filter(SupplshNames, SupplNames(lElement, 1))
        If UBound(arChk) < 0 Then
            '   name not in sheet names, create
            Sheets("Template").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = SupplNames(lElement, 1)
            StoreSheetNamesInArray SupplshNames ' refresh name list with new name
        End If
    
    '   Now check for new entries
        bFlag = False
    '       first check if PO number exists on current supplier sheet
        Set rPO = Sheets(SupplNames(lElement, 1)).Range("B:B").Find(what:=CStr(RTM(lElement, 2)), _
                    lookat:=xlWhole, searchdirection:=xlNext)
        If Not rPO Is Nothing Then  ' PO number exists
            lPO = rPO.Row
            ' check to see if current UPC is on sheet against this PO number
            Do
                If CStr(rPO.Offset(0, -1).Value) = CStr(RTM(lElement, 1)) Then
                    '   Record exists
                    bFlag = True
                    Exit Do
                End If
                Set rPO = Sheets(SupplNames(lElement, 1)).Range("B:B").Find(what:=RTM(lElement, 2), _
                    after:=rPO, lookat:=xlWhole, searchdirection:=xlNext)
                
            Loop While rPO.Row > lPO
            '   looped through records without finding matching pair PO & UPC
            '   so add record
            
'        Else
'            'PO number does not exist, write record to sheet
'            WriteRecord CStr(SupplNames(lElement, 1)), RTM, lElement
        End If
            If Not bFlag Then WriteRecord CStr(SupplNames(lElement, 1)), RTM, lElement
        
    Next lElement
    
End Sub

Sub StoreSheetNamesInArray(strNames() As String)
Dim lElement As Long
Dim wsSht As Worksheet

    For Each wsSht In ActiveWorkbook.Worksheets
        lElement = lElement + 1
        ReDim Preserve strNames(1 To lElement)
        strNames(lElement) = wsSht.Name
    Next wsSht
    
'    For lElement = LBound(strNames) To UBound(strNames)
'        MsgBox "Array element " & lElement & _
'            " has a value of " & strNames(lElement) & "." & _
'            " Cell A1 of this Sheet = " & Sheets(strNames(lElement)).Range("A1")
'    Next lElement
    
End Sub

Sub WriteRecord(Supplier As String, RTM(), lElement As Long)
    Dim lRow As Long
    
    Sheets(Supplier).Select
    If Range("A11").Value = vbNullString Then   ' sheet is empty
        lRow = 11
    Else
        lRow = Range("A10").End(xlDown).Row + 1
    End If
    
    With Application
        ' write out  row:
        Range("A" & lRow & ":L" & lRow).Value = .Index(RTM, lElement, 0)
    End With
    
End Sub

I suggest to add this code into a new module. You can link the subroutine CheckAndCopyRTM to a button on the summary sheet, that the user can press after adding new items.

__________________________________________________

To really improve the sheet you could also create a userform to take the input and write it on the summary sheet when the OK button is pressed. that way you can ensure that all the doata is entered correctly and completely. Plus that a similar (but simpler) macro could run to add the new line to the relevant supplier sheet.

let me know if it all works!

 

[richardjshaffer]

Thank you very much, this is fantastic and will save us a huge amount of time.

Just one last tweak please, can we copy the supplier number (eg F1111) to go into cell F6 in the sheet that is created for this supplier,

thank you

Richard

 

[richardjshaffer]

Thank you very much, this is fantastic and will save us a huge amount of time.

Just one last tweak please, can we copy the supplier number (eg F1111) to go into cell F6 in the sheet that is created for this supplier, and similiarly for every supplier?

thank you

Richard

 

[sijpie]

Option Explicit
Sub CheckAndCopyRTM()
'   subroutine to check through SUMMARY sheet for all
'   RTMs to be copied to Supplier sheets. Create
'   Supplier sheet if required
'
    Dim RTM() As Variant, SupplshNames() As String, SupplNames As Variant
    Dim SupplCount As Long, lElement As Long, bFlag As Boolean
    Dim arChk, rPO As Range, rUPC As Range, lPO As Long, lUPC As Long
    
    
    SupplCount = Sheets("SUMMARY").Range("B6").End(xlDown).Row - 6
    If SupplCount > 60000 Then '    sheet is empty
        MsgBox "No RTMs on sheet."
        Exit Sub
    End If
    ReDim RTM(1 To SupplCount, 1 To 13)
'    ReDim SupplNames(1 To SupplCount)
'    With Application
'        av = .Index(Cells, [row(1:10)], Array(1, 3, 6, 2))
'    End With
    
    Sheets("SUMMARY").Activate
    
    With Application
                        ' copy SUMMARY data into RTM array, with columns in same order as
                        ' required for output in individual supplier sheets
        lElement = SupplCount + 6
        RTM = .Index(Cells, Evaluate("row(7:" & lElement & ")"), Array(6, 3, 4, 5, 9, 8, 10, 11, 12, 13, 14, 16))
    End With
    
    SupplNames = Range("B7:B" & SupplCount + 6) ' set SupplNames to supplier names
   
    StoreSheetNamesInArray SupplshNames     ' store the sheet names of workbook
    
    
    For lElement = LBound(SupplNames) To UBound(SupplNames)
    '   check for new names
        arChk = Filter(SupplshNames, SupplNames(lElement, 1))
        If UBound(arChk) < 0 Then
            '   name not in sheet names, create
            Sheets("Template").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = SupplNames(lElement, 1)
            StoreSheetNamesInArray SupplshNames ' refresh name list with new name
            activesheet.Range("F6").value = SupplNames(lElement, 1)
        End If
    
    '   Now check for new entries
        bFlag = False
    '       first check if PO number exists on current supplier sheet
        Set rPO = Sheets(SupplNames(lElement, 1)).Range("B:B").Find(what:=CStr(RTM(lElement, 2)), _
                    lookat:=xlWhole, searchdirection:=xlNext)
        If Not rPO Is Nothing Then  ' PO number exists
            lPO = rPO.Row
            ' check to see if current UPC is on sheet against this PO number
            Do
                If CStr(rPO.Offset(0, -1).Value) = CStr(RTM(lElement, 1)) Then
                    '   Record exists
                    bFlag = True
                    Exit Do
                End If
                Set rPO = Sheets(SupplNames(lElement, 1)).Range("B:B").Find(what:=RTM(lElement, 2), _
                    after:=rPO, lookat:=xlWhole, searchdirection:=xlNext)
                
            Loop While rPO.Row > lPO
            '   looped through records without finding matching pair PO & UPC
            '   so add record
            
'        Else
'            'PO number does not exist, write record to sheet
'            WriteRecord CStr(SupplNames(lElement, 1)), RTM, lElement
        End If
            If Not bFlag Then WriteRecord CStr(SupplNames(lElement, 1)), RTM, lElement
        
    Next lElement
    
End Sub

Sub StoreSheetNamesInArray(strNames() As String)
Dim lElement As Long
Dim wsSht As Worksheet

    For Each wsSht In ActiveWorkbook.Worksheets
        lElement = lElement + 1
        ReDim Preserve strNames(1 To lElement)
        strNames(lElement) = wsSht.Name
    Next wsSht
    
'    For lElement = LBound(strNames) To UBound(strNames)
'        MsgBox "Array element " & lElement & _
'            " has a value of " & strNames(lElement) & "." & _
'            " Cell A1 of this Sheet = " & Sheets(strNames(lElement)).Range("A1")
'    Next lElement
    
End Sub

Sub WriteRecord(Supplier As String, RTM(), lElement As Long)
    Dim lRow As Long
    
    Sheets(Supplier).Select
    If Range("A11").Value = vbNullString Then   ' sheet is empty
        lRow = 11
    Else
        lRow = Range("A10").End(xlDown).Row + 1
    End If
    
    With Application
        ' write out  row:
        Range("A" & lRow & ":L" & lRow).Value = .Index(RTM, lElement, 0)
    End With
    
End Sub