เขียนVBA:การกระจายข้อมูลdataตามsheetที่เป็นชื่อร้านvendorนั้นๆ

[nattapon-G]

DATA test by vendor.xlsx

ผมอยากจะกระจายข้อมูลที่เกี่ยวกับชิ้นงานโดยจะแบบตามประเภทvendorแต่ละที่ครับ โดยvendorแต่ละที่จะมีsheetอยู่และในsheetนั้นจะมีข้อมูลของชิ้นงานประจำvendorนั้นๆ

Code: Select all

Sub vencollect()
    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 Then
            s.Delete
        End If
    Next s
    With Sheets(1)
        For Each r In .Range("c2", .Range("c" & .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("z1").Value = "Vendor"
                s.Range("z2").Value = r.Value
                .UsedRange.AdvancedFilter xlFilterCopy, _
                    s.Range("z1:z2"), s.Range("a1")
                s.Range("z1:z2").Clear
            End If
        Next r
    End With
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
End Sub

อันนี้เป็นโค้ดที่ผมลองแล้วพบปัญหาที่" s.Name = r.Value" ขึ้นว่า Method 'name' of object '_Workbook' failed" (1004) ครับ
ผมเลยอยากได้โค้ดที่สามารถกระจายข้อมูลที่เกี่ยวกับชิ้นงานโดยจะแบบตามประเภทvendorแต่ละที่และตั้งชื่อSheetเป็นชื่อvendorนั้นๆครับ

[snasui]

กรุณาแนบไฟล์ที่มี Code นั้นแล้วมาอีกครั้งครับ

ไฟล์ที่มี Code จะต้องมีนามสกุล .xlsm เป็นอย่างน้อย ไม่ใช่ .xlsx อย่างที่แนบมาครับ

[nattapon-G]

นี่ครับขอบคุณครับ

[snasui]

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

Code: Select all

Sub vencollect()
    Dim r As Range, d As Object, s As Worksheet
    Dim strShName As String
    Set d = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = 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("c2", .Range("c" & .Rows.Count).End(xlUp))
            If IsError(r.Value) Then
                MsgBox "Found error in '" & r.Address(0, 0) & _
                    "' please check your data.", vbExclamation
                Exit Sub
            End If
            strShName = VBA.Replace(r.Value, ": ", "_")
            If Not d.Exists(strShName) And strShName <> "" Then
                d.Add strShName, strShName
                Set s = Worksheets.Add(after:=Worksheets(Sheets.Count))
                s.Name = strShName
                s.Range("z1").Value = "Vendor"
                s.Range("z2").Value = r.Value
                .UsedRange.AdvancedFilter xlFilterCopy, _
                    s.Range("z1:z2"), s.Range("a1")
                s.Range("z1:z2").Clear
            End If
        Next r
    End With
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
End Sub

[nattapon-G]

ขอบคุณครับอาจารย์