Help Me Create A Macro Please

[pure vito]

Hi Everyone,

I'm just looking for some help please in creating a macro to help me automate this task,

In the first image column "B" is my list of parts, each part has a zone it belongs to, column "G", So from here each zone is given a Pick Number Column "N" based on the Line number in image 2

This is one pick request, in the second image is my pick tracker and the line number is what is important to us column "A" the request is broken into zones and then the line number in column "A"
is what we are using in image 1 column "N", but we have to input that on each part that is in the same zone as you can see in image 1 column "N",

I'm finding this hard to explain so I hope with these images you can see what I'm trying to do, when I input the parts into image one then the macro would go to column "N" find the first " " and paste the pick numbers
based on the line number and zone in image 2,

Sorry if your struggling to understand my issue I'm hopeful some questions from yourselves might make things a little more clear, Thanks In Advance

Iv'e Just realised my line numbers are out by one 2_4 Combi should be 2678 and so on

 

[ZMyrrh]

Public Sub PickNumber()
Dim i As Integer
Dim j As Integer

'Makes Code Run Faster
Application.Calculation = xlCalculationManual


'Enter Sheet1 Name For Example Worksheets("Production")
'This is picture 1 from the Forum
Dim s1 As Worksheet: Set s1 = Worksheets("Sheet1")

'This is picture 2 from the Forum
'Enter Sheet2 Name For Example Worksheets("Received")
Dim s2 As Worksheet: Set s2 = Worksheets("Sheet2")


Let i = WorksheetFunction.CountA(s1.Range("n1:n10000")) + 1

For k = i To WorksheetFunction.CountA(s1.Range("a1:a10000"))

Start1:

    For j = 2 To WorksheetFunction.CountA(s2.Range("a1:a10000"))
  
        If s1.Cells(k, 7).Value = s2.Cells(j, 3).Value And s2.Cells(j, 3).Value <> "" Then
          
            s1.Cells(k, 14).Value = Right(s2.Cells(j, 1).Value, 4)
          
            k = k + 1
          
            GoTo Start1
          
        End If
  
    Next j

Next k

'Make Sure You Turn This On. If any errors of not your worksheet not calculating you need to enter "Application.Calculation = xlCalculationAutomatic" into the VBA Immediate Window and press "Enter" while running over that code.
Application.Calculation = xlCalculationAutomatic


End Sub

Make Sure You Read The Comments In The Code.

For the Code to work properly you will need dates in the first picture and also Line Numbers from the second picture. My code does a CountA to count the used cells on both sheets.

So you need to add this to that worksheets' modules. If you need help I recommend googling "How to insert code in VBA"
After you will want to create a "CommandButton" and "Assign the Macro to that Button".

Best of luck!

Tell me how it goes!

 

[pure vito]

Hi ZMyrrh,

Thank you so much for taking this on and spending the time,

However I have been able to get it to run and add the numbers where I need them, but it's just not giving me the right numbers if that makes sense
I seem to be getting the same number, if you wouldn't mind assisting me further I have added a copy of the two sheets I'm using and again thanks for your time

My Document

 

[ZMyrrh]

Hi pure vito,

Would you mind giving me the values that the last four values in column N on the "LSA" sheet are supposed to be? I am finding that there are a few 2R Main on the other page. I'm wondering how the code should look for it to make sense.

 

[pure vito]

Hi ZMyrrh, of course,

First a pick request is generated and parts are added to "LSA" I then take the zones from column G remove the duplicates and add them to "Pick Status" sheet column C, what ever line number is next that zone then has to go into "LSA" column N, I hope this makes sense, and again thanks for your time,

 

[ZMyrrh]

This should work as long as you add a button and run this almost every time you enter the information that way you don't have the most recent pick number for "2R Main" which may be wrong based on which one you want. So do it often is all I'm saying. Here's the code! Let me know if it works!

'Enter Sheet1 Name For Example Worksheets("Production")
'This is picture 1 from the Forum
Dim s1 As Worksheet: Set s1 = Worksheets("LSA")

'This is picture 2 from the Forum
'Enter Sheet2 Name For Example Worksheets("Received")
Dim s2 As Worksheet: Set s2 = Worksheets("Pick status")


Let i = WorksheetFunction.CountA(s1.Range("n1:n100000")) + 1

For k = i To WorksheetFunction.CountA(s1.Range("a1:a100000"))

Start1:

    For j = 2 To WorksheetFunction.CountA(s2.Range("a1:a100000"))
 
        If s1.Cells(k, 7).Value = s2.Cells(j, 3).Value And s2.Cells(j, 3).Value <> "" Then
         
            If Left(s2.Cells(j, 1).Value, 4) = "LINE" Then
                ii = Right(s2.Cells(j, 1).Value, 4)
            Else
                ii = s2.Cells(j, 1).Value
           
            End If
           
            s1.Cells(k, 14).Value = ii
                     
        End If
 
    Next j

Next k

'Make Sure You Turn This On. If any errors of not your worksheet not calculating you need to enter "Application.Calculation = xlCalculationAutomatic" into the VBA Immediate Window and press "Enter" while running over that code.
Application.Calculation = xlCalculationAutomatic


End Sub

 

[pure vito]

ZMyrrh, That's absolute genius you've got the job done thank you so much for your help it works perfectly, even trying to read the code i have no idea how you've done that Thank You

 

[ZMyrrh]

That’s great man! Anything else you want automated I got you!

 

[pure vito]

Oh I could Keep you here for days and thank you,

I'll just leave my documents here just in case you get bored

24MY BOH.xlsm

Shared with Dropbox

www.dropbox.com

New Pick Form - Test - Copy.xlsm

Shared with Dropbox

www.dropbox.com

 

[pure vito]

Hi @ZMyrrh

Sorry to be a pain but there is one thing that would complete this process for me if you can find the time,

In the New Pick Form Document when you select the zones and populate the sheet I then print off individual sheets using the print button, it automatically prints a sheet for each zone (Sheet2 hidden),
then I take the line number (Pick Number) we created and hand write it onto the respective sheet, between the two documents I'd love to have the sheet print off with it's Pick Number already established in the 24MY BOH, I hope this makes sense and again Thanks for taking the time even if you can just offer advise I'd really appreciate it Below is the code I am currently using to print

Sub Macroprintsheet()

    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    
    Application.ScreenUpdating = False
     Sheets("Pick Form").Select
    Sheets("Sheet2").Visible = True
    
'   *** Change Sheet name to suit ***
        Range("A4:G462").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("D3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets("Pick Form").Select
Range("H3").Select
    Set Sh = Worksheets("Sheet2")
    Set Rng = Sh.Range("G3:G" & Sh.Range("G65536").End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("G2:G" & Sh.Range("G65536").End(xlUp).Row)
    For Each Item In List
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Sh.PrintOut
        Rng.AutoFilter
    Next Item
    Sheets("Pick Form").Select
      Sheets("Sheet2").Select
    ActiveWindow.SelectedSheets.Visible = False
  
    Application.ScreenUpdating = True

End Sub