วิธีการแยก sheet ข้อมูลเป็น หลายๆ file

[Kullaphorn Won]

รบกวนสอบถามผู้รู้ค่ะ เรามีวิธีการแยก sheet ข้อมูลเป็น หลายๆ file ได้ยังไงบ้างคะ
จาก sheet List_Survey ต้องการแยกเป็น File ตาม Supplier ค่ะ
(ตามตัวอย่าง file ที่แนบมายกตัวอย่างเป็น sheet name = A123)

ขอบคุณล่วงหน้าค่ะ

[puriwutpokin]

แบบนั้นต้องใช้VBAครับลงเขียนมาก่อนตามกฏข้อ5ครับติดตรงไหนมาถามกันในนี้ครับ
ในเพจนี้ก็มีคำถามแนวนี้อยู่ครับลองค้นดูครับ

[Bo_ry]

Delete Column I และ Row 2 ที่เว้นว่างไว้

เลือก A2
Insert Pivot Table

PART NO., PART NAME, Team ไว้ที่ Rows
A,B,C,D Price ไว้ที่ Values
Sale name ไว้ที่ Filter


Tab Analyze > Options > Show report Filter pages > OK

[Kullaphorn Won]

ลองทำ macro ดูแล้วค่ะ เหมือนจะทำได้ แต่ไม่ทราบว่าต้องเขียน code เพิ่มยังไงให้มันวน loop ไปเป็น file อื่นต่อไป รบกวนชี้แนะด้วยค่ะ ขอบคุณค่ะ

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'

'
    Columns("A:J").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$J$807").AutoFilter Field:=3, Criteria1:="A123"
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir "C:\Users\Kullaphorn.Won\Desktop\Tier-N FY20"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Kullaphorn.Won\Desktop\Tier-N FY20\A123.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    Windows("Test1.xlsm").Activate
End Sub

[Kullaphorn Won]

Delete Column I และ Row 2 ที่เว้นว่างไว้

เลือก A2
Insert Pivot Table

PART NO., PART NAME, Team ไว้ที่ Rows
A,B,C,D Price ไว้ที่ Values
Sale name ไว้ที่ Filter


Tab Analyze > Options > Show report Filter pages > OK

_/\_ ขอบคุณมากค่ะน้องพยายามทำ pivot เองแล้วแต่เรียงข้อมูลยังไงก็ไม่เหมือนต้นฉบับ ตอนนี้เข้าใจแล้วค่ะ คุณเก่งมากเลยค่ะ
แต่ไม่ทราบว่าถ้าเราใช้ pivot วิธีนี้จะไม่สามารถแยกเป็นหลายๆ file ได้ใช่ไหมคะ ?
เราต้อง copy ,save as ไปเองใช่หรือไม่คะ?

[Bo_ry]

วิธี pivot แยกไฟล์ไม่ได้

VBA

Code: Select all

Sub SplitBook()
Application.ScreenUpdating = False
Dim NB As Workbook, Name As String
Dim Data As Range, L As Long, A As Long

With ThisWorkbook.Sheets(1)
    Set Data = .Range("A1:J" & .Range("A999999").End(xlUp).Row)
    .Range("L1") = "Supplier"
    Data.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("L1"), Unique:=True
    A = .Range("L999999").End(xlUp).Row
    For L = 2 To A
        If .Range("L2") <> "" Then
            Set NB = Workbooks.Add
            Data.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("L1:L2"), CopyToRange:=NB.Sheets(1).Range("A1")
            Name = "C:\Users\Kullaphorn.Won\Desktop\Tier-N FY20\" & .Range("L2").Value & ".xlsx"
            NB.SaveAs Filename:=Name
            NB.Close
        End If
        .Range("L2").Delete Shift:=xlUp
    Next L
    
    .Columns("L").Clear
    .Range("a1").Select
End With
Application.ScreenUpdating = True
End Sub