Snasui Excel Forum

Posted: **Tue Feb 18, 2020 2:29 pm**

รบกวนหน่อยครับอาจารย์ผมใส่ Code ดังนี้ แล้ว error ตรง s.Name = r.Value และกระจายได้แค่ sheet เดียวเองครับ

g.xlsm

Sub DistributeDataToSheets()
Dim r As Range, d As Object, s As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each s In Worksheets
If s.Name <> Sheets(1).Name Then
s.Delete
End If
Next s
With Sheets(1)
For Each r In .Range("b2", .Range("b" & .Rows.Count).End(xlUp))
If Not d.Exists(r.Value) Then
Set s = Worksheets.Add(after:=Worksheets(Sheets.Count))
s.Name = r.Value
s.Range("f1").Value = "Department Code"
s.Range("f2").Value = r.Value
.UsedRange.AdvancedFilter xlFilterCopy, _
s.Range("f1:f2"), s.Range("a1")
s.Range("f1:f2").Clear
End If
Next r
End With
Application.ScreenUpdating = True
MsgBox "Finish", vbInformation
End Sub

Posted: **Tue Feb 18, 2020 2:42 pm**

winitnan wrote: Tue Feb 18, 2020 2:29 pm รบกวนหน่อยครับอาจารย์ผมใส่ Code ดังนี้ แล้ว error ตรง s.Name = r.Value และกระจายได้แค่ sheet เดียวเองครับg.xlsm

Sub DistributeDataToSheets()
Dim r As Range, d As Object, s As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each s In Worksheets
If s.Name <> Sheets(1).Name Then
s.Delete
End If
Next s
With Sheets(1)
For Each r In .Range("b2", .Range("b" & .Rows.Count).End(xlUp))
If Not d.Exists(r.Value) Then
Set s = Worksheets.Add(after:=Worksheets(Sheets.Count))
s.Name = r.Value
s.Range("f1").Value = "Department Code"
s.Range("f2").Value = r.Value
.UsedRange.AdvancedFilter xlFilterCopy, _
s.Range("f1:f2"), s.Range("a1")
s.Range("f1:f2").Clear
End If
Next r
End With
Application.ScreenUpdating = True
MsgBox "Finish", vbInformation
End Sub

ควรแนบโค้ดให้เป็นโค้ดตาม วิธี ด้านบน และให้แนบไฟล์ตัวอย่างมาด้วยเพื่อสะดวกต่อการตอบของเพื่อนสมาชิกครับ

Posted: **Tue Feb 18, 2020 2:45 pm**

ขอโทษทีครับ แนบแล้วครับ

Posted: **Tue Feb 18, 2020 3:58 pm**

ที่แรก คีย์ข้อมูลตามรูป หรือ หาค่าไม่ซ้ำจากคอลัมน์ B ก็ได้
และปรับโค้ดตามนี้ดูครับ

Code: Select all

Sub DistributeDataToSheets()
    Dim r As Range, d As Object, s As Worksheet
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    For Each s In Worksheets
        If s.Name <> Sheets(1).Name Then
            s.Delete
        End If
    Next s
    With Sheets(1)
    last = .Cells(.Rows.Count, "b").End(xlUp).Row
        For Each r In .Range("f2", .Range("f" & .Rows.Count).End(xlUp))
            If Not d.Exists(r.Value) Then
                Set s = Worksheets.Add(After:=Worksheets(Sheets.Count))
                s.Name = r.Value
                s.Range("f1").Value = "Department Code"
                s.Range("f2").Value = r.Value
                .Range("a1:d" & last).AdvancedFilter xlFilterCopy, _
                    s.Range("f1:f2"), s.Range("a1")
                s.Range("f1:f2").Clear
            End If
        Next r
    End With
    Application.ScreenUpdating = True
    MsgBox "Finish", vbInformation
End Sub

Snasui Excel Forum

สอบถามกระจายข้อมูลออกเป็นหลาย sheet

สอบถามกระจายข้อมูลออกเป็นหลาย sheet

Re: สอบถามกระจายข้อมูลออกเป็นหลาย sheet

Re: สอบถามกระจายข้อมูลออกเป็นหลาย sheet

Re: สอบถามกระจายข้อมูลออกเป็นหลาย sheet