Copy row from one worksheet to worksheet named using cell reference

[scarlett3]

I gather data from an external source into one worksheet, entitled 'Paste'. It will look like the following:

Worksheet Date text1 text2
alpha 05/08/2019 text text
gamma 05/08/2019 text text

I then copy the row with 'alpha' in column A and paste to the bottom of the current rows of text in the 'alpha' worksheet, copy the row with 'gamma' and paste to the bottom of the current rows of text in the 'gamma' worksheet and so on.

It is rather tiresome when there are about 100 rows to copy over to the relevant worksheet.

Can someone help me with a macro that will read each row, copy that row to the worksheet name in column A, and repeat this for all non-empty rows in the 'Paste' worksheet?

Thanks

 

[Fluff]

How about

Sub scarlett3()
   Dim Cl As Range
   Dim Ws As Worksheet
   Dim Ky As Variant
   
   Set Ws = Sheets("Paste")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         If Cl.Value <> "" Then .Item(Cl.Value) = Empty
      Next Cl
      For Each Ky In .keys
         If Evaluate("isref('" & Ky & "'!a1)") Then
            Ws.Range("A1").AutoFilter 1, Ky
            Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Sheets(Ky).Range("A" & Rows.Count).End(xlUp).Row
         End If
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub

 

[scarlett3]

Thanks Fluff!

I've tried the script and it generates the following error: 'Run-time error '1004': Copy method of Range class failed'

When it paused, a filter in column A has been activated on the value for cell A2 and the debugging highlighted the line 'Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Sheets(Ky).Range("A" & Rows.Count).End(xlUp).Row'

 

[Fluff]

Do you have a header in row 1 with data starting in A2?
Also do you have any merged cells?

 

[scarlett3]

Yes, header in row 1 and data starting in A2.

There are no merged cells.

 

[Fluff]

Oops
Remove the word in red

            Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Sheets(Ky).Range("A" & Rows.Count).End(xlUp)[COLOR=#ff0000].Row[/COLOR]

 

[scarlett3]

Hi Fluff

Thanks for the edit. The macro now completes.

Just one issue...

When it copies to the row to the relevant worksheet, it overwrite the final row in the destination worksheet. Could you amend it so that it pastes below the current text in the destination worksheet?

 

[Fluff]

I'll get right eventually (honest)
It should be

            Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Sheets(Ky).Range("A" & Rows.Count).End(xlUp)[COLOR=#ff0000].Offset(1)[/COLOR]

 

[scarlett3]

Brilliant!

This is going to save me so much time :D

 

[Fluff]

You're welcome & thanks for the feedback