Как сказал tkacprow, нет инструмента «из коробки», который сделает это для вас превосходным. Для этого вам обязательно понадобится макрос VBA.
Я только что загрузил на свой сайт пример инструмента/книги, в который встроен необходимый макрос VBA. Не стесняйтесь использовать и изменять это для удовлетворения потребностей http://tomwinslow.co.uk/handy-excel-tools/.
Сообщите мне, если это не совсем то, что вы ищете, и я могу попробовать его исправить.
Надеюсь, это поможет.
Ниже приведен код, который вы предпочитаете, а не загружаете с моего сайта.
Sub splitMasterList()
Dim MAST As Worksheet
Set MAST = Sheets("MASTER")
Dim headerRng As Range
Dim areaSelectionCount As Long
Dim areaSelectionIsValid As Boolean
Dim areaSelectionRow As Long
Dim splitColRng As Range
Dim themeExists As Boolean
Dim themeArray() As String
ReDim Preserve themeArray(1 To 1)
Dim lastRow As Long
Dim lastSheetTabRow As Long
Dim i As Long
Dim ii As Long
Dim theme As String
Dim doesSheetExist As Boolean
Dim ws As Worksheet
Dim sheetTabRowCounter As Long
'ask the user to highlight the table header
On Error Resume Next
Set headerRng = Application.InputBox(prompt:="Please select the headings of all columns that you wish to utilise." & vbNewLine & vbNewLine & "Note: Hold the 'Ctrl' key to select multiple ranges." & vbNewLine & vbNewLine, Default:="", Type:=8)
On Error GoTo 0
If headerRng Is Nothing Then
'notify user that the process cannot continue
' MsgBox "You must select a range to undertake this process."
'exit the sub
Exit Sub
End If
'check how many areas were selected and that they all have 1 row and are all on the same line
areaSelectionCount = headerRng.Areas.Count
areaSelectionIsValid = True
areaSelectionRow = 0
'loop through all areas checking they are a vald header
i = 1
For i = 1 To areaSelectionCount
'check selection area row count
If headerRng.Areas(i).Rows.Count <> 1 Then
areaSelectionIsValid = False
End If
'check selection area row
If areaSelectionRow = 0 Then
'set areaSelectionRow
areaSelectionRow = headerRng.Areas(i).Row
Else
'test areaSelectionRow variable against the row of the area selection
If areaSelectionRow <> headerRng.Areas(i).Row Then
areaSelectionIsValid = False
End If
End If
Next i
'exit if the area selection is not valid (FALSE)
If areaSelectionIsValid = False Then
'notify user that the process cannot continue
MsgBox "You may only select headings from a single row. Please try again."
'exit the sub
Exit Sub
End If
'ask the user to select the cell heading which they would like to plit their data on
On Error Resume Next
Set splitColRng = Application.InputBox("Select a cell from anywhere in the column which you want to use to classify (split) your data.", Default:="", Type:=8)
On Error GoTo 0
If splitColRng Is Nothing Then
'notify user that the process cannot continue
MsgBox "You must select a cell to undertake this process. Please start again."
'exit the sub
Exit Sub
End If
On Error GoTo errorHandling
'turn updating off
Application.ScreenUpdating = False
'loop down the master data and
lastRow = MAST.Cells(MAST.Rows.Count, "C").End(xlUp).Row
'loop down the items in the table and build an array of all themes (based on the user split cell selection)
For i = headerRng.Row + 1 To lastRow
'if the theme is blank then insert place holder
If MAST.Cells(i, splitColRng.Column).Value = "" Then
MAST.Cells(i, splitColRng.Column).Value = "Blank/TBC"
End If
'get the theme
theme = MAST.Cells(i, splitColRng.Column).Value
'check if the theme exists in the array yet
themeExists = False
ii = 1
For ii = 1 To UBound(themeArray)
If themeArray(ii) = theme Then
'stop loop and do not add current theme to the array
themeExists = True
End If
Next ii
If themeExists = False Then
'add current theme
themeArray(UBound(themeArray)) = MAST.Cells(i, splitColRng.Column).Value
ReDim Preserve themeArray(1 To UBound(themeArray) + 1)
End If
Next i
'notify the user how many themes there are going to be
' MsgBox "The table is about to be split into " & UBound(themeArray) - 1 & " seperate sheets, each containing grouped data based on the column you selected."
'loop through the theme array and build a :
'-sheet
'-table
'-rows
'for each theme
ii = 1
For ii = 1 To UBound(themeArray) - 1
'check if sheet exists
'check if a worksheet by the name of this theme exists and create one if not
'returns TRUE if the sheet exists in the workbook
doesSheetExist = False
For Each ws In Worksheets
If Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25) = ws.Name Then
doesSheetExist = True
End If
Next ws
'create sheet if it does not exist
If doesSheetExist = False Then
'create sheet after the master sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
'max sheet name is 31 characters and cannot contain special characters
ws.Name = Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)
Else
'do not creat sheet but activate the existing
Sheets(Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)).Activate
Set ws = ActiveSheet
End If
'delete any old data out of the sheet
lastSheetTabRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
If lastSheetTabRow < 4 Then
lastSheetTabRow = 4
End If
ws.Rows("4:" & lastSheetTabRow).Delete Shift:=xlUp
'copy table header into each sheet tab
headerRng.Copy
ws.Range("B4").Select
ws.Paste
'insert title and time stamp details into new sheet
ws.Range("B2").Value = themeArray(ii)
ws.Range("B2").Font.Size = 22
ws.Range("B2").Font.Bold = True
ws.Range("B1").Font.Size = 8
ws.Range("C1:D1").Font.Size = 8
ws.Range("C1:D1").Cells.Merge
ws.Range("B1").Value = "Timestamp : "
ws.Range("C1").Value = Now()
ws.Range("C1").HorizontalAlignment = xlLeft
ws.Range("E1").Value = "Updates must NOT be done in this worksheet!"
ws.Range("E1").Font.Color = vbRed
'loop down the items in the master table and copy them over to the correct sheet tabs based on selected theme/column
sheetTabRowCounter = 1
i = headerRng.Row + 1
For i = headerRng.Row + 1 To lastRow
'copy item from master into theme tab if matches the theme
If MAST.Cells(i, splitColRng.Column).Value = themeArray(ii) Then
'copy row
MAST.Activate
headerRng.Offset(i - headerRng.Row, 0).Copy
'paste row
ws.Activate
ws.Cells(sheetTabRowCounter + 4, 2).Select
ws.Paste
'add one to the sheet row couter
sheetTabRowCounter = sheetTabRowCounter + 1
End If
Next i
Next ii
'format new sheet
'loop through all theme sheets and size their columns to match tre master sheet
ii = 1
For ii = 1 To UBound(themeArray) - 1
Sheets(Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)).Activate
Set ws = ActiveSheet
'loop through all of the columns on the master table and get their size
i = headerRng.Column
For i = headerRng.Column To (headerRng.Column + headerRng.Columns.Count + 1)
ws.Columns(i).ColumnWidth = MAST.Columns(i).ColumnWidth
Next i
'loop down sheet tab and autofit all row heights
ws.Rows.AutoFit
ws.Columns("A").ColumnWidth = 2
ws.Activate
'hide gridlines
ActiveWindow.DisplayGridlines = False
'freeze panes
ActiveWindow.FreezePanes = False
ws.Cells(5, 1).Select
ActiveWindow.FreezePanes = True
ws.Range("A1").Select
Next ii
'loop through all sheets and delete sheets where the timestamp exists but is older than 5 seconds
For Each ws In Worksheets
'check if cell contains a date
If IsDate(ws.Range("C1").Value) = True And ws.Range("B1").Value = "Timestamp : " Then
'delete when sheet is older than 10 seconds
If (Now() - ws.Range("C1").Value) < 10/86400 Then
'MsgBox "OK - " & Now() - ws.Range("C1").Value
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next ws
Application.CutCopyMode = False
'activate the master sheet
MAST.Activate
MAST.Range("A1").Select
'turn updating back on
Application.ScreenUpdating = True
'notify user process is complete
MsgBox "Done!"
Exit Sub
errorHandling:
'notify the user of error
'activate the master sheet
MAST.Activate
MAST.Range("A1").Select
'turn updating back on
Application.ScreenUpdating = True
'notify user process is complete
MsgBox "Something went wrong! Please try again." & vbNewLine & vbNewLine & "Note: This error may be being caused by an invalid heading selection range." & vbNewLine & vbNewLine & "If the problem persists contact Tom Winslow for assistance."
End Sub
К сожалению, Excell заметно не хватает в этом отделе ... Если это возможно (готов переехать в другой пакет?), Вы можете рассмотреть возможность использования функции FILTER() в Google Таблицах – user3616725