Как раскидать строки по листам?

Question

[Антон]

Например, имеется лист:

Требуется средствами макроса VBA раскидать строки по разным листам. В результате должны получится листы с названиями из значений второго столбца:
"1"

"2"

"3"

"4"

"5"

p.s. не нужно писать мне обращаться на фрилансерские биржи за решением, я надеюсь исключительно на энтузиазм прогеров, которым будет даже интересно решить подобную задачку, коим образом и сам иногда помогаю людям, безвозмездно.

Answer 1

[h8nor]

' Таблица с данными должна начинаться с ячейки A1, лист активен. Старые данные не очищаются.
Option Explicit
Option Base 1
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789

Sub Создать_листы_по_последнему_столбцу()
  Dim a As Integer, k As Byte, m As Variant
  
  With ThisWorkbook
    With .ActiveSheet
      m = .Cells(1, 1).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count)
    End With
    For a = LBound(m, 1) + 1 To UBound(m, 1)
      k = FindSheet(m(a, UBound(m, 2)))
      If k = 0 Then
        .Sheets.Add After:=.Sheets(.Sheets.Count): k = .Sheets.Count
        With .Sheets(k)
          .Name = m(a, UBound(m, 2))
          .Cells(1, 1) = m(LBound(m, 1), 1): .Cells(1, 2) = m(LBound(m, 1), 2)
        End With
      End If
      With .Sheets(k)
        .Cells(.UsedRange.Rows.Count + 1, 1) = m(a, LBound(m, 2)) ' Нижняя граница "m"
        .Cells(.UsedRange.Rows.Count + IIf(Val(Application.Version) >= 12, 0, 1), _
          2) = m(a, UBound(m, 2)) ' Верхняя граница "m"
      End With
    Next a
  End With
End Sub

Function FindSheet(ByVal SheetName As String) As Byte
  Dim GetBook As Workbook, GetSheet As Worksheet
  
  Set GetBook = ThisWorkbook
  For Each GetSheet In GetBook.Worksheets
    If GetSheet.Name = SheetName Then FindSheet = GetSheet.Index: Exit For
  Next GetSheet: Set GetSheet = Nothing: Set GetBook = Nothing
End Function