แมโคร Excel 2010 เพื่อแยกไฟล์ข้อมูลขนาดใหญ่ลงในสมุดงาน

ฉันพบรหัสบางอย่างที่ทำงานได้อย่างสมบูรณ์เพื่อแยกไฟล์ตามคอลัมน์ (บรรทัดที่ 31) เป็นแท็บแยกต่างหากภายในแผ่นงาน

ฉันแค่ต้องการให้แยกไฟล์ตามคอลัมน์ในเวิร์กบุ๊กแยกต่างหากและยังพร้อมที่จะเพิ่มคำต่อท้ายเพื่อระบุแต่ละไฟล์

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 = 6 ' 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

ความคิดเห็นเกี่ยวกับวิธีการแก้ไขนี้?

นี่เป็นมาโครที่ฉันทำงานเมื่อไม่กี่เดือนที่ผ่านมา อาจช่วยได้ ถ้าไม่คุณสามารถดูวิธีสร้างสมุดงานใน CopySheet () Sub และปรับแมโครปัจจุบันของคุณ

การกระทำของผู้ใช้ : มาโครแจ้งให้คุณทราบสำหรับหมายเลขคอลัมน์ (C = 3) ที่จะหารด้วยและแถวใดที่จะเริ่มต้นที่ (โดยทั่วไปคือแถวแรกด้านล่างส่วนหัว) แมโครนี้ไม่พร้อมท์สำหรับคำต่อท้าย แต่จะตั้งชื่อสมุดงานโดยอัตโนมัติด้วยค่าคอลัมน์และบันทึกไว้ใน \ Split \ โฟลเดอร์ย่อย

ความต้องการ : สิ่งนี้ต้องการให้ตารางของคุณถูกเรียงลำดับตามคอลัมน์หลักของคุณ

บริบท : ฉันทำให้เป็นหลักในการแยก PivotTables ขนาดใหญ่ (แปลงเป็นค่าที่มีมาโครอื่นเป็นอันดับแรก) บนป้ายกำกับแถวแรกในโหมดเลย์เอาต์ เนื่องจากตารางเหล่านั้นมีเซลล์ว่างจำนวนมากซึ่งเป็นเพียงการซ้ำซ้อนที่ซ่อนอยู่จึงไม่ต้องพึ่งพาตัวกรองและแทนที่จะไปจากบนลงล่าง - ดังนั้นความต้องการที่เรียงลำดับ

วิธีการ : เมื่อใดก็ตามที่พบค่าใหม่ในคอลัมน์ที่ระบุมันจะคัดลอกแผ่นงานต้นฉบับทั้งหมดไปยังหนังสือเล่มใหม่ทุกครั้งจากนั้นลบแถวทั้งหมดก่อนและหลังส่วนปัจจุบัน (ตัวแปร iFirstRow, iStartRow, iStopRow, iTotalRows จะใช้ในการติดตาม ของชิ้นส่วนเหล่านั้น) วิธีนี้จะช่วยให้การจัดรูปแบบการตั้งค่าหน้าสูตร ฯลฯ ที่คุณอาจมีในหนังสือต้นฉบับของคุณ

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2012-03-05
'
' Description
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1

            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0

            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If

    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Exit
        Exit Do
    End If
Loop

'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " documents saved in " + sFilePath


End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub


Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook

     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet

     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Select left-topmost cell
     ash.Cells(1, 1).Select

     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")

     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub