รบกวนค่ะ มีวิธีแยก sheet ได้ครั้งเดียวทีละมากๆ ค่ะ

[ศุภาพิชญ์]

รบกวนค่ะ พอดีได้งานมาทำ ค่ะ หัวหน้าให้แยก sheet เพื่อ save เป็นไฟล์ใหม่ เปิด youtube เห็นวิธีทำ เหมือนงานที่ได้มา คือแยก sheet เพื่อ save ไฟล์ใหม่ค่ะ พอลองทำดูตามวีดีโอ แต่ขึ้น error ค่ะ รบกวนหน่อยค่ะ ไม่รู้ตรงไหนผิด ลองมาหลายครั้งแล้วค่ะ พอดีงานรีบมากค่ะ หัวหน้ารีบใช้ข้อมูล ขอบคุณนะค่ะ

ขึ้น error ค่ะ
อยากได้ไฟล์ตั้งชื่อตามนี้ค่ะ

27032017กระเป๋า5
27032017กระเป๋า6
27032017เสื้อหนา7
27032017เสื้อแขนยาว8
27032017เสื้อหนา9

ขอบคุณมากนะค่ะ (พอดีพึ่งหัดลองทำค่ะ เนื่องจากต้องแยกชีตจำนวนมากค่ะ)

cc cd ce cf cg ch ci cj data data
ขาย ขาย ขาย ขาย ขาย ขาย ขาย 27032017กระเป๋า5 27032017กระเป๋า5
ซื้อ ซื้อ ซื้อ ซื้อ ซื้อ ซื้อ ซื้อ 27032017กระเป๋า6 27032017กระเป๋า6
ขาย ขาย ขาย ขาย ขาย ขาย ขาย 27032017เสื้อหนา7 27032017เสื้อหนา7
เช่า เช่า เช่า เช่า เช่า เช่า เช่า 27032017เสื้อแขนยาว8 27032017เสื้อแขนยาว8
ซื้อ ซื้อ ซื้อ ซื้อ ซื้อ ซื้อ ซื้อ 27032017เสื้อหนา9 27032017เสื้อหนา9


Sub Macro1()

ThisWorkbook.ActiveSheet.Columns("CP:FY").EntireColumn.Delete
For r = 2 To Range("CM6").End(xlUp).Row
Range("CN2").Value = Range("CM" & r).Value
Xdata = Range("CN2")Value
Range("A1").Select
Selection.CurrentRegion.Select
Range("A1:CK6").AdvancedFiter Action:xlFiterCopy, CriteriaRange:=_
Range ("CN1:CN2"), CopyToRange:=Range("CP1"), Unique:=True

Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & " \ " & Xdata & ".xlsx"

ThisWorkbook.Sheets(1).Columns("CP:FY").Copy
Windows(xdata) & ".xlsx").Activate
ActiveSheet.Columns("a:a").EntireColumn.Insert
ThisWorkbook.ActiveSheet.Columns("CP:FY").EntireColumn.Delete
Application.CutCopyMode = False
ActiveWorkbookClose True
Next r
End Sub

Range("A1:CK6").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"CN1:CN2"), CopyToRange:=Range("CP2"), Unique:=True
End Sub

[ศุภาพิชญ์]

ขอโทษค่ะ Range("A1:CK6").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"CN1:CN2"), CopyToRange:=Range("CP2"), Unique:=True
End Sub (3 บรรทัดสุดท้าย copy หลงไปค่ะ) ขอบคุณมากค่ะ

[puriwutpokin]

จาก VBA โค้ดที่ให้มาดูนั้น ผิดหลายจุดเลยครับ ต้องถามก่อนว่า เจตนาที่ ต้องการออกมาเป็นหน้าตา แบบไหน ทำตัวอย่าง แบบที่ต้องการมาดู
แล้วโค้ดที่ให้มาดู ก็เหมือนมีการปรับแต่งผิด รูปแบบไปจนไม่ชัดเจนว่า ลักษณะงานนั้นเป็นอย่างไรครับ ลองทำตามที่แจ้งก่อนละครับ ตัวอย่างไฟล์ที่ต้องการว่ามีข้อมูลอะไรบ้างครับ แล้วเพื่อนๆสมาชิกจะได้เข้าถึงปัญหาได้เร็วขึ้นครับ

[snasui]

กรุณาอ่านวิธีการแนบ Code ตามกฎการใช้บอร์ดข้อ 5 ด้านบนด้วยครับ

[ศุภาพิชญ์]

ขอบคุณนะค่ะ พอดีข้อมูลเต็มไฟล์ใหญ่มากมีประมาณ20000บรรทัดค่ะ มีคอลัมภ์ตั้งแต่ a-cj ค่ะ เลยยกตัวอย่างไฟล์สั้นๆ มาค่ะ
พอดีลองทำตาม youtubeอันนี้ค่ะ https://youtu.be/p2I5xYTHlzE,และhttps:/ ... 0gXMCY2ITc ค่ะ แต่ขึ้นerror ตลอดค่ะ ขอบคุณมากนะค่ะ ลองทำตามหลายหน ไม่รู้ตรงไหนปิด พอดีไม่เคยทำเลย กำลังพยายามศึกษาค่ะ

[ศุภาพิชญ์]

no data value data data
1 data11 22 data11 data11
2 data8 40 data8
3 data7 31 data7
4 data7 13 data9
5 data9 16 data1
6 data8 39 data12
7 data1 80 data3
8 data7 77 data5
9 data12 45 data4
10 data3 79 data10
11 data5 26 data2
12 data5 11 data6
13 data5 21
14 data4 40
15 data12 32
16 data12 52
17 data11 77
18 data8 96
ไฟล์เหมือนแบบนี้ค่ะ รบกวนค่ะ ขอบคุณมากค่ะ ขอโทษค่ะ หาวิธีแนบโค้ดข้อ 5 ไม่เจอค่ะ โค้ดนี้พิมพ์เหมือนในyoutube ค่ะ ไฟล์งานที่จะได้มาเป็นแบบนี้ค่ะ แต่แถวยาวกว่าค่ะ
Sub Macro1()

ThisWorkbook.ActiveSheet.Columns("H:J").EntireColumn.Delete
For r = 2 To Range("E19").End(xlUp).Row
Range("F2").Value = Range("e" & r).Value
Xdata = Range("F2")Value
Range("A1").Select
Selection.CurrentRegion.Select
Range("A1:CK6").AdvancedFiter Action:xlFiterCopy, CriteriaRange:=_
Range ("F1:F2"), CopyToRange:=Range("H1"), Unique:=True

Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & " \ " & Xdata & ".xlsx"

ThisWorkbook.Sheets(1).Columns("H:J").Copy
Windows(xdata) & ".xlsx").Activate
ActiveSheet.Columns("a:a").EntireColumn.Insert
ThisWorkbook.ActiveSheet.Columns("H:J").EntireColumn.Delete
Application.CutCopyMode = False
ActiveWorkbookClose True
Next r
End Sub

[ศุภาพิชญ์]

พิมพ์ตามใน youtubeค่ะ ตาม book2 รบกวนหน่อยค่ะ ลองทำหลายหนไม่ได้เลยขึ้น errorตลอดเลยค่ะ (post ไม่ค่อยเป็น ขอโทษนะค่ะ) ปกติจะเข้ามาดูปัญหาตลอด เพราะมีพี่ๆ ถามตรงที่อยากรู้ตลอด แต่เรื่องแยกไฟล์มากๆ ไม่มี เลย post ค่ะ

[ศุภาพิชญ์]

โทษค่ะ book2 ไฟล์แนบไม่ไป เดียวลองใหม่นะค่ะ

[snasui]

ดูวิธีการโพสต์ Code ตามกฎข้อ 5 ด้านบน แล้วโพสต์ให้แสดงเป็น Code มาใหม่ครับ

[ศุภาพิชญ์]

Code: Select all

Sub Macro1()
   
ThisWorkbook.ActiveSheet.Columns("H:J").EntireColumn.Delete
For r = 2 To Range("E19").End(xlUp).Row
Range("F2").Value = Range("e" & r).Value
Xdata = Range("F2")Value
Range("A1").Select
Selection.CurrentRegion.Select
Range("A1:CK6").AdvancedFiter Action:xlFiterCopy, CriteriaRange:=_
Range ("F1:F2"), CopyToRange:=Range("H1"), Unique:=True

Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & " \ " & xdata & ".xlsx"

ThisWorkbook.Sheets(1).Columns("H:J").Copy
Windows(xdata) & ".xlsx").Activate
ActiveSheet.Columns("a:a").EntireColumn.Insert
ThisWorkbook.ActiveSheet.Columns("H:J").EntireColumn.Delete
Application.CutCopyMode = False
ActiveWorkbookClose True
Next r
End Sub

[ศุภาพิชญ์]

ขอบคุณมากนะค่ะ

[puriwutpokin]

ตามที่แจ้งไปข้างต้นครับ ต้องการ กรองข้อมูล แล้ว คัดลอกไปสร้างเป็นไฟล์ใหม่ชื่อตาม เซลใช่ไหมครับ ลองแนบไฟล์ที่เป็นคำตอบของ ตัวอย่างที่ต้องการ ว่า อะไรมาอย่างไร แล้วไปสร้างมีอะไรเป็นเงื่อนไขครับ

[ศุภาพิชญ์]

ใช่ค่ะ เหมือนมีไฟล์ผลรวม auto filler แล้วแตกไฟล์ ไปสร้างworksheetใหม่และsave เป็นชื่อ data 1 ,data2 ,data3 ไปจนครบทุกรายการในช่องคอลัมภ์e ในไฟล์ที่ชื่อไฟล์ data อันใหม่ค่ะ ขอบคุณมากค่ะ

[puriwutpokin]

ปรับโค้ดเป็น

Code: Select all

Sub Test()
Dim xdata As String
For r = 2 To Range("E19").End(xlUp).Row
ThisWorkbook.ActiveSheet.Columns("H:J").EntireColumn.Delete
Range("F2").Value = Range("E" & r).Value
xdata = Range("F2").Value
            Range("A1").Select
    Selection.CurrentRegion.Select
    Range("A1:C19").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "F1:F2"), CopyToRange:=Range("H1"), Unique:=True
        ActiveSheet.Columns("H:J").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & xdata & ".xlsx"
Application.CutCopyMode = False
ActiveWorkbook.Close True
Next r
End Sub

[ศุภาพิชญ์]

ขอบคุณมากนะค่ะ

[ศุภาพิชญ์]

ขอบคุณค่ะ ทำตามขั้นตอนอันนี้ค่ะ ไม่รู้ทำตรงไหนผิดค่ะ

[puriwutpokin]

ลองแนบไฟล์ที่ใส่โค้ดมาดูกันครับ

[ศุภาพิชญ์]

พอดีมาหาหมอ ตอนเย็นๆกลับค่ะเดียวส่งไฟล์ไปให้นะค่ะ ขอบคุณมากค่ะ

[ศุภาพิชญ์]

ไฟล์ใส่ code ขอบคุณนะค่ะ

[puriwutpokin]

ลองดูตามไฟล์แนบนะครับ ผมก็คัดลอกมาลงปกติครับ แต่อันหนึ่งที่ต้องเป็น คือ data ควรมีจำนวนเลขเท่ากันเช่น
data11
data01
ไม่ใช่
data11
data1
เพราะเวลาดึงข้อมูลมามันจะไม่ถูกต้องครับ