Copy to sheet based on cell value

[Bengo]

Hi, I am trying to write a macro to copy data from a master sheet, to the relevant supplier sheet, based on the name in one of the cells

For example, in A1 to D1 of the master sheet I might have:

19/12/2017 | SUPPLIER A | £5000 | MANAGER A

And in A2 to D2:

19/12/2017 | SUPPLIER B | £1000 | MANAGER B

I'd like to be able to run the script to add the info in row 1 to a worksheet I already have named as "SUPPLIER A", and the info from row 2 to be copied to a worksheet already named "SUPPLIER B"

I am working on a VBA based on highlighting the desired cells and copying them to the relevant worksheet, but and struggling to make the destination worksheet be based on which supplier is in the info. Hope this makes sense! Any help would be much appreciated! Thanks

 

[Fluff]

Does your actual data start in row 1, or do you have a header in row 1, with data starting in row 2?

 

[Bengo]

Sorry was trying to keep it simple, data actually starts in row 7, and will be added to as time goes on downwards

My code currently looks like (but is far away from where I want to get to):

Sub POsort()
'
' POsort Macro
'
Dim strName As String
strName = ?????

'
Selection.Copy
Sheets(strName).Select
Range("B7").Select
ActiveSheet.Paste
End Sub

thanks for looking

 

[Fluff]

How about

Sub AddSht_FltrPaste()

   Dim Cl As Range
   Dim UsdRws As Long
   Dim OSht As Worksheet

Application.ScreenUpdating = False

   Set OSht = Sheets("Summary")
   UsdRws = OSht.Range("A" & Rows.Count).End(xlUp).row
   If OSht.AutoFilterMode Then OSht.AutoFilterMode = False
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("B7:B" & UsdRws)
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            OSht.Range("A7").AutoFilter Field:=2, Criteria1:=Cl.Value
            OSht.Range("A6:A" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
               Sheets(Cl.Text).Range("A1")
         End If
      Next Cl
   End With
   OSht.Range("A6").AutoFilter

End Sub

This assumes that you have a header row in row 6

 

[Bengo]

Hmm ok I'll have a good look through this, as very different to what I was looking at (i.e looks much better!)

I had got up to here, with the supplier name being in the 5th cell along in the row of data I was selecting, and was getting a syntax error in strName = line...

Sub POsort()
'
' POsort Macro
'

Dim strName As String
strName = Worksheets(ActiveCell.Offset(0, 5).Value

'
Selection.Copy
Sheets(strName).Select
Range("B7").Select
ActiveSheet.Paste

End Sub

 

[Bengo]

How about

Sub AddSht_FltrPaste()

   Dim Cl As Range
   Dim UsdRws As Long
   Dim OSht As Worksheet

Application.ScreenUpdating = False

   Set OSht = Sheets("Summary")
   UsdRws = OSht.Range("A" & Rows.Count).End(xlUp).row
   If OSht.AutoFilterMode Then OSht.AutoFilterMode = False
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("B7:B" & UsdRws)
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            [COLOR=#ff0000]OSht.Range("A7").AutoFilter Field:=2, Criteria1:=Cl.Value
            OSht.Range("A6:A" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.Copy _[/COLOR]
               Sheets(Cl.Text).Range("A1")
         End If
      Next Cl
   End With
   OSht.Range("A6").AutoFilter

End Sub

This assumes that you have a header row in row 6

Hi, got back to working on this thank you. I'm getting a script out of range error on the lines I've highlighted in RED above... and no sheets are being created. Any ideas at all? Many thanks

 

[Fluff]

What column is your supplier name in?
In your OP its col B, but looking at post#5 it's 5 columns to the right of the activecell.

 

[Bengo]

Hi thanks. It's in column "F", I did try and change references to that column, but the value of Cl always seems to be that of column B, I'll add a screenshot so you can see what I have:

 

[Bengo]

Actually I can't figure out how to add a screenshot...

 

[Fluff]

Ok, try

Sub AddSht_FltrPaste()

   Dim Cl As Range
   Dim UsdRws As Long
   Dim OSht As Worksheet

Application.ScreenUpdating = False

   Set OSht = Sheets("Summary")
   UsdRws = OSht.Range("A" & Rows.Count).End(xlUp).Row
   If OSht.AutoFilterMode Then OSht.AutoFilterMode = False
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("F7:F" & UsdRws)
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            OSht.Range("A6").AutoFilter Field:=6, Criteria1:=Cl.Value
            OSht.Range("A6:A" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
               Sheets(Cl.Text).Range("A1")
         End If
      Next Cl
   End With
   OSht.Range("A6").AutoFilter

End Sub