Developing.ru

Код: Выделить всё

Function GetSh(ByVal name As String) As Worksheet
On Error GoTo others
  Set GetSh = Application.ActiveWorkbook.Worksheets.Item(name)
  Exit Function
others:
  Set GetSh = Application.ActiveWorkbook.Worksheets.Item("Разное")
End Function

Sub qwe()
Dim row As Range, sh As Worksheet, R As Long
  For Each row In Application.ActiveWorkbook.Sheets("General").Cells(1, 1).CurrentRegion.Rows
    Set sh = GetSh(row.Range("D1").Value)
    row.Copy sh.Cells(Application.WorksheetFunction.Count(sh.Columns(1)) + 1, 1)
  Next
End Sub

Код: Выделить всё

Public Sub РазбрасывательСтрок()
     Dim r As Range
     Dim ws As Worksheet
     Dim s As String
     Dim l As Long
    
     Application.ScreenUpdating = False
     With Worksheets("Общий")
           For Each r In .Cells(2, 4).Resize(.Cells(.Rows.Count, 4).End(xlUp).Row - 1, 1)
                s = "," & Replace(r.Value, " ", vbNullString)
                l = Len(s)
                For Each ws In ActiveWorkbook.Worksheets
                     If Not (ws.Name = "Общий" Or ws.Name = "Разное") Then
                          s = Replace(s, "," & ws.Name, vbNullString)
                          If Len(s) < l Then    'Элемент присутствует
                               r.EntireRow.Copy _
                                    ws.Rows(Application.WorksheetFunction.CountA(ws.Columns(3)) + 1)
                               l = Len(s)
                          End If
                     End If
                Next ws
                s = Replace(s, ",", vbNullString)
                If Len(s) > 0 Then    'присутствуют дополнительные имена
                     Set ws = ActiveWorkbook.Worksheets("Разное")
                     r.EntireRow.Copy _
                          ws.Rows(Application.WorksheetFunction.CountA(ws.Columns(3)) + 1)
                End If
          Next r
     End With
     Application.ScreenUpdating = True
End Sub