Developing.ru

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

Public Sub РазбрасывательСтрок()
    Dim r As Range
    Dim wsr As Worksheet
    Dim s As String
    Dim l As Long, ll As Long, i As Long, j As Long, k As Long, m As Long
    Application.ScreenUpdating = False
    'Сортируем имена допустимых листов по убыванию длины имени
    With ActiveWorkbook
          Set wsr = .Worksheets("Разное")
          ReDim ws(1 To .Worksheets.Count - 2) As Worksheet
          k = 0
          For i = 1 To .Worksheets.Count
              With .Worksheets(i)
                   If .Name <> "Общий" Then
                      .Range(.[A2], .[A2].SpecialCells(xlLastCell)).ClearContents
                  End If
              End With
              If InStr(1, "Общий|Разное", .Worksheets(i).Name, vbBinaryCompare) = 0 Then    'приемлемое имя листа
                   l = Len(.Worksheets(i).Name)
                   If k = 0 Then
                         ll = l
                   Else
                         ll = Len(ws(k).Name)
                   End If
                   If ll >= l Then
                        k = k + 1
                        Set ws(k) = .Worksheets(i)
                   Else
                         For j = k To 1 Step -1
                              If Len(ws(j).Name) < l Then
                                    Set ws(j + 1) = ws(j)
                              Else
                                    Set ws(j + 1) = .Worksheets(i)
                                    Exit For
                              End If
                          Next j
                          If j = 0 Then
                               Set ws(1) = .Worksheets(i)
                          End If
                          k = k + 1
                    End If
              End If
          Next i
    End With
    With Worksheets("Общий")
        For Each r In .Cells(2, 4).Resize(.Cells(.Rows.Count, 4).End(xlUp).Row - 1, 1)
            s = Trim$(r.Value)
            l = Len(s)
            For i = 1 To UBound(ws)
                s = Replace(s, ws(i).Name, vbNullString, 1, 1, vbBinaryCompare)
                If Len(s) < l Then    'Элемент присутствует
                    r.EntireRow.Copy _
                            ws(i).Rows(Application.WorksheetFunction.CountA(ws(i).Columns(3)) + 1)
                    l = Len(s)
                End If
            Next i
            s = Replace(s, ",", vbNullString)
            s = Replace(s, ";", vbNullString)
            s = Replace(s, " ", vbNullString)
            'добавьте сюда замену для других возможных разделителей
            If Len(s) > 0 Then    'присутствуют дополнительные имена
                r.EntireRow.Copy _
                        wsr.Rows(Application.WorksheetFunction.CountA(wsr.Columns(3)) + 1)
            End If
        Next r
    End With
    Application.ScreenUpdating = True
End Sub