กระจายชีทเดียวไปหลายๆชีทตามค่าใน column ที่กำหนด

[Jancha]

จาก code ตามตัวอย่างคลิปนี้ https://www.youtube.com/watch?v=L7YlYoC ... Co&index=9 ได้ลองนำมาปรับใช้ โดยที่ sheet 1 เป็นข้อมูลที่ต้องการกระจายไปเป็น หลายๆ sheet ตาม column B คือ cost center (ถ้าตามไฟล์กระจายได้ 2 sheet คือ sheet In และ sheet out) และได้ลองเพิ่มข้อมูลด้านบนตารางที่ row1-row6 เข้าไป ต้องรบกวนปรับ code เพื่อให้ copy ข้อมูลด้านบนตางราง row1-row6 ไปได้ด้วยครับ ได้ทำตัวอย่างที่ต้องการไว้ที่ sheet in and sheet out แนบมาแล้วครับ

Code: Select all

Sub CreateShs()
    Dim r As Range, d As Object, S As Worksheet
    Set d = CreateObject("scripting.dictionary")
    
    Application.DisplayAlerts = False
    For Each S In Worksheets
        If S.Name <> Sheets(1).Name And S.Name <> Sheets(2).Name Then              'ลบทุก sheet ยกเว้น sheet1 & sheet2
            S.Delete
        End If
    Next S
     
    With Sheets(1)
                For Each r In .Range("b8", .Range("b" & .Rows.count).End(xlUp))
                             If Not d.exists(r.Value) Then
                                d.Add r.Value, r.Value
                                Set S = Worksheets.Add(after:=Worksheets(Sheets.count))
                                S.Name = r.Value
                                S.Range("AZ1").Value = "CC"
                                S.Range("AZ2").Value = r.Value
                                .UsedRange.AdvancedFilter xlFilterCopy, _
                                   S.Range("AZ1:AZ2"), S.Range("A7")
                             S.Range("AZ1:AZ2").Clear

                              End If
                Next r
       End With
             
    
    Sheets("Sheet1").Select
    Range("b8").Select
    Selection.AutoFilter
    Selection.End(xlDown).Select
    
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
    
   End Sub

[snasui]

ไม่พบว่ามีการปรับเพิ่ม Code ให้มีการคัดลอกบรรทัดที่ 1 ถึง 6 และปรับแก้ตำแหน่งการวางข้อมุลให้ตรงกับตำแหน่งที่ต้องการวางในชีตต่าง ๆ แต่อย่างใด กรุณาปรับสิ่งเหล่านี้มาก่อนครับ

[Jancha]

ลองปรับ code มาตามนี้ครับ แต่ละ row เขียน remark ไว้ไม่ทราบว่าเข้าใจถูกตามที่เขียนไหมครับ กลายเป็นว่า copy ได้แต่ row1-6 ข้อมูลที่ loop เก็บค่าใน columb b ไม่มาด้วย

Code: Select all

Sub CreateShs()
    Dim r As Range, d As Object, S As Worksheet
    Set d = CreateObject("scripting.dictionary")
    
    Application.DisplayAlerts = False
    For Each S In Worksheets
        If S.Name <> Sheets(1).Name And S.Name <> Sheets(2).Name Then              'ลบทุก sheet ยกเว้น sheet1 & sheet2
            S.Delete
        End If
    Next S
     
    With Sheets(1)
                For Each r In .Range("b8", .Range("b" & .Rows.count).End(xlUp))
                             If Not d.exists(r.Value) Then
                                d.Add r.Value, r.Value
                                Set S = Worksheets.Add(after:=Worksheets(Sheets.count))
                                S.Name = r.Value

                                S.Range("AZ7").Value = "CC"                            'row filter ให้ชื่อ cc วางไว้ที่ AZ7
                                S.Range("AZ8").Value = r.Value                         'data ที่ loop ได้เก็บไว้ที่ AZ8
                                .UsedRange.AdvancedFilter xlFilterCopy, _
                                   S.Range("AZ7:AZ8"), S.Range("a7")                'Copy data จาก filter ให้ CC วาง row 7 และ data วาง row 8 ลงไป
                                S.Range("AZ7:AZ8").Clear                                 'Clear filter

                                Sheets("Sheet1").Select                                     'ไป sheet แรก
                                Rows("1:6").Copy                                            'copy row 1-6
                                S.Paste                                                           'วางใน sheet สุดท้ายที่สร้าง row 1-6

                              End If
                Next r
       End With
             
    
    Sheets("Sheet1").Select
    Range("b8").Select
    Selection.AutoFilter
    Selection.End(xlDown).Select
    
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
    
   End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

สังเกตการเยื้อง ว่าเข้าออกประมาณไหน การเยื้องที่มากหรือน้อยเกินไปจะทำให้อ่าน Code ลำบากกว่าปกติครับ

Code: Select all

Sub CreateShs()
    Dim r As Range, d As Object, S As Worksheet
    Set d = CreateObject("scripting.dictionary")
    
    Application.DisplayAlerts = False
    For Each S In Worksheets
        If S.Name <> Sheets(1).Name And S.Name <> Sheets(2).Name Then              'ลบทุก sheet ยกเว้น sheet1 & sheet2
            S.Delete
        End If
    Next S
    
    With Sheets(1)
        For Each r In .Range("b8", .Range("b" & .Rows.Count).End(xlUp))
            If Not d.exists(r.Value) Then
                d.Add r.Value, r.Value
                Set S = Worksheets.Add(after:=Worksheets(Sheets.Count))
                S.Name = r.Value
                
                S.Range("AZ7").Value = "CC"                            'row filter ให้ชื่อ cc วางไว้ที่ AZ7
                S.Range("AZ8").Value = r.Value                         'data ที่ loop ได้เก็บไว้ที่ AZ8
                .UsedRange.Offset(6, 0).AdvancedFilter xlFilterCopy, _
                    S.Range("AZ7:AZ8"), S.Range("a7")                'Copy data จาก filter ให้ CC วาง row 7 และ data วาง row 8 ลงไป
                S.Range("AZ7:AZ8").Clear                                 'Clear filter
                .Range("a1:n6").Copy S.Range("a1")
'                Sheets("Sheet1").Select                                     'ไป sheet แรก
'                Rows("1:6").Copy                                            'copy row 1-6
'                S.Paste                                                           'วางใน sheet สุดท้ายที่สร้าง row 1-6
            
            End If
        Next r
    End With
    
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation

End Sub

[Jancha]

ขอบคุณครับ F8 ดูทีละ step โค้ดส่วนใหญ่พอเข้าใจแล้วครับ เหลือแต่บรรทัดนี้รบกวนอธิบายหน่อยครับ .UsedRange.Offset(6, 0).AdvancedFilter xlFilterCopy, _ ตรง Offset(6, 0) มีความสัมพันธ์กับ range az7 ที่เป็น CC ใช่เปล่าครับ ถ้ากำหนด CC ให้อยู่ที่ row ไหนก็ต้องเลือก filter row นั้น 6 คือการขยับลง 7 row(เพราะการอ้างเป็น index เริ่มจาก 0,1,2,3,4,5,6) และทำการ filter ถ้ากำหนดให้ CC อยู่ที่ AZ10 จะเป็น Offset(9, 0) ก็คือขยับลง 10 row เข้าใจถูกไหมครับ

[snasui]

ตรง .UsedRange เป็น Code ต่อเนื่องมาจาก With Sheets(1)

ดังนั้น Statement นี้จริง ๆ คือ Sheets(1).UsedRange แปลว่า พื้นที่การใช้งานของ Sheet1 ซึ่งพื้นที่การใช้งานเริ่มที่ A1 สิ้นสุดที่มุมขวาล่างของบรรทัดและคอลัมน์ที่เคยมีข้อมูลหรือเคยใช้งาน

.UsedRange.Offset(6, 0) หมายถึงจากพื้นที่ข้างต้นให้ลงไปด้านล่าง 6 บรรทัด ไปทางขวา 0 คอลัมน์ เพื่อให้ไปยังพื้นที่ที่ต้องการ Filter ข้อมูลไปใช้ วัตถุประสงค์ของ Statement นี้คือแค่นี้

ในการใช้ Advanced Filter ส่วนที่เป็น Criteria จะอยู่ตำแหน่งใดก็ได้เพียงแต่ต้องเป็นช่วงเซลล์ สำหรับงานนี้บังเอิญว่ากำหนดให้อยู่ในบรรทัดเดียวกันเท่านั้น แต่ไม่ใช่ว่าต้องกำหนดให้เป็นบรรทัดเดียวกันเสมอครับ

[Jancha]

กระจ่างครับ ขอบคุณมากครับ