Excel 스프레드시트의 내용을 별도의 스프레드시트로 분할하는 매크로가 있습니까?

Question

비슷한 질문이 있다는 것을 알고 있지만 완전히 똑같지는 않다고 생각합니다.

다음 제목이 포함된 Excel 스프레드시트가 있습니다.

First name -- Surname -- Host Trust -- Contact details -- etc -- etc

그것은 큰 스프레드시트입니다. 나는 매주 호스트 트러스트에 이메일을 보내 누가 그들과 함께 일할 것인지 알려야 하며 이를 수동으로 나누는 것은 악몽입니다.

열의 데이터를 Host Trust각 스프레드시트의 제목으로 사용하여 이 스프레드시트를 여러 스프레드시트로 분할하는 매크로를 생성할 수 있습니까?

Answer 1

사용 중인 Excel 버전이 무엇인지 모르므로 이것이 작동한다고 보장할 수 없습니다. 요청한 대로 수행하고(테스트했습니다) C열에 대한 필터링을 구입하고 각 고유 레코드에 대한 탭을 만든 다음 해당 행을 새 시트에 복사합니다. 데이터 범위와 일치하도록 코드를 위쪽으로 수정해야 합니다.

어떤 일을 하기 전에;파일의 복사본을 백업으로 만드세요.

VBA에 익숙하다면 Alt+를 F11누르면 VBA 창이 열리며 이 코드를 직접 복사할 수 있습니다. 저장되면 실행할 수 있도록 매크로 목록에 나타납니다.

크레딧이 필요한 곳에 크레딧을 제공하기 위해 다음에서 이것을 찾았습니다.엑셀 포럼.

Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim ErrNum As Long

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A1:O2000") '  & LastRow(ActiveSheet))
    My_Range.Parent.Select

    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    'This example filters on the first column in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 3 ' I changed this to 3 for column C

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Range.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
             Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            'Check if there are no more then 8192 areas(limit of areas)
            CCount = 0
            On Error Resume Next
            CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                     .Areas(1).Cells.Count
            On Error GoTo 0
            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                'Add a new worksheet
                Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = cell.Value
                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                    Err.Clear
                End If
                On Error GoTo 0

                'Copy the visible data to the new worksheet
                My_Range.SpecialCells(xlCellTypeVisible).Copy
                With WSNew.Range("A1")
                    ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                    ' Remove this line if you use Excel 97
                    .PasteSpecial Paste:=8
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                    .Select
                End With
            End If

            'Show all data in the range
            My_Range.AutoFilter Field:=FieldNum

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

    MsgBox ("Copy Complete - - Remember to save your work.")


End Sub