If a word in a cell in col A matches the name of a worksheet, move row to that sheet

[1819]

The code below comes from

http://stackoverflow.com/questions/24632623/move-row-to-another-worksheet-where-cell-equals-worksheet-name

.

It works to move rows that match the name of a worksheet to that worksheet.

Please could someone suggest how to amend it to achieve this: (in pseudocode)

If a cell contains a word which matches the name of worksheet, move the row to that worksheet.

Work in the order of the worksheets so that if there is a duplicate, move to the first match.

So if you had "Vote Leave or Remain" in the cell, and "Leave" and "Remain" as worksheets, the row would be moved to "Leave".

Ideally I would like the code to be able to cope with dynamic worksheet names (that is, not having to write in the worksheets' names in the code)

Sub Main()
    Sheets("All Data").Activate
    Range("A2").Activate
    Dim SheetToPaste As String
    Do While ActiveCell.Value <> ""
        Select Case ActiveCell.Value
            Case "Hoja2"
                SheetToPaste = "Hoja2"
            Case "Hoja3"
                SheetToPaste = "Hoja3"
            Case Else
                SheetToPaste = "Mismatch"
        End Select
        ActiveCell.EntireRow.Copy
        Sheets(SheetToPaste).Activate
        Range("A2").Activate
        ActiveCell.EntireRow.Insert
        Application.CutCopyMode = False
        Sheets("All Data").Activate
        ActiveCell.EntireRow.Delete
    Loop
End Sub

Thanks!

[snb]

Sub M_snb()
  sn=sheets("all data").columns(1).specialcells(2,2)
  redim sp(sheets.count)

  for j=1 to sheets.count
   sp(j)=sheets(j).name
  next

  for j=1 to ubound(sn)
    for jj=1 to ubound(sp)
      if instr(sn(j,1),sp(jj)) then exit for
    next
    if jj<= ubound(sp) then sheets(sp(j)).cells(rows.count,1).end(xlup).offset(1).resize(,ubound(sn,2))=application.index(sn,j)
  next
End Sub

[1819]

Thanks very much for your rapid reply.

I'm getting a "Compile error: variable not defined" at "sn" in the extract below:

  sn=sheets("all data").columns(1).specialcells(2,2)

Please could you possibly suggest a fix?

Thanks.

[snb]

Remove option explicit.

[1819]

Many thanks. I am now getting "Run time error 13: type mismatch" at this point:

Sheets(sp(j)).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, UBound(sn, 2)) = Application.Index(sn, j)

Please could you suggest a solution?

[mdmackillop]

try

Set sn=sheets("all data").columns(1).specialcells(2,2)

[1819]

try

Set sn=sheets("all data").columns(1).specialcells(2,2)

Thanks but the same error ("Run time error 13: type mismatch") now appears at

For j = 1 To UBound(sn)

Any ideas?

[snb]

You have to analyse the code, debug & adapt it if necessary yourself.
You shouldn't use code you don't understand.

[1819]

You have to analyse the code, debug & adapt it if necessary yourself.
You shouldn't use code you don't understand.

That's an unnecessary comment.

We all have much to learn. We learn by doing things we have not done before.

I was grateful that you offered an answer, but it didn't work.

So it was reasonable to ask for further help.

What's the point of a forum if people put up wrong answers and then walk away?

[snb]

Nothing wrong in the answer.....

[mdmackillop]

Posting a sample workbook allows responders to test their code. Without this, you need to do your own debugging.

[1819]

Posting a sample workbook allows responders to test their code. Without this, you need to do your own debugging.

I'm sorry I did not do that in the first place.

I've attached a specimen file in which worksheet "Commentary" has data in column A.

The aim is to move all rows containing the names of the other worksheets - here Texas and Germany - to those worksheets.

I've included the macro proposed above but I'm getting a runtime error as described.

Thanks

Specimen.xlsm

[mdmackillop]

Option Explicit
Sub M_snb()
    Dim sn, sp()
    Dim j As Long, jj As Long
    sn = Sheets("Commentary").Columns(1).SpecialCells(2, 2)
    ReDim sp(Sheets.Count)
     
    For j = 1 To Sheets.Count
        sp(j) = Sheets(j).Name
    Next
     
    For j = 1 To UBound(sn)
        For jj = 1 To UBound(sp)
            If InStr(sn(j, 1), sp(jj)) Then Exit For
        Next
        If jj <= UBound(sp) Then Sheets(sp(jj)).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, UBound(sn, 2)) = Application.Index(sn, j)
    Next
End Sub

[snb]

Your description didn't match your file.

Put this in the sheet 'commentary' codemodule:

Sub M_snb()
  sn = Application.Transpose(Sheets("Commentary").cells(1).CurrentRegion.Columns(1).Value)
    
  For Each sh In Sheets
    sp =Filter(sn, sh.Name)
    If UBound(sp) > -1 Then sh.Cells(1).Resize(UBound(sp) + 1) = Application.Transpose(sp)
  Next
End Sub

NB. remove all 'option explicit'

[1819]

Thank you - both solutions worked. This is excellent - you will save me a lot of tedious work.

(I could only give out one rep at a time. I'll come back).