ต้องการแยก sheet ตามชื่อลูกค้าโดยใช้ Marco

[March201711]

อยากทราบว่าถ้าเราต้องการแยกชื่อลูกค้าแต่ละราย แยกออกเป็นแต่ละชีท โดยใช้ marco โดย column A1 เป็นชื่อลูกค้า A2 เป็นชื่อลูกค้าต่อลงกันไป และ ข้อมูล B1 ถึง H1ต้องเอาข้อมูลมาด้วย แยกเป็นชีทๆค่ะ

[snasui]

การใช้งาน Macro จำเป็นต้องเขียนมาเองก่อน จากนั้นแนบไฟล์พร้อม Code ที่เขียนมาเองแล้วพร้อมอธิบายสิ่งที่ยังเป็นปัญหาครับ

[March201711]

ต้องการ run marco แยกเป็นรายชื่อลูกค้าออกเป็นแต่ละชีท โดยดูชื่อลูกค้าที่ Colum V แล้วตั้งชื่อ sheet เอาแค่ชื่อ ไม่เอานามสกุลเข้ามา ซึ่งจะ copy ตั้งแต่ column B ถึง column J ค่ะ
เช่น Mr.Manit ให้เปิด sheet ใหม่ตั้งชื่อ Mr.Manit แล้ว copy B4 ถึง J4
Mr.Pravit ให้เปิด sheet ใหม่ตั้งชื่อ Mr.Pravit แล้ว copy B5 ถึง J5
Mr.Ratch ให้เปิด sheet ใหม่ตั้งชื่อ Mr.Ratch แล้ว copy B6 ถึง J6
Mr.Yoth ให้เปิด sheet ใหม่ตั้งชื่อ Mr.Yoth แล้ว copy B7 ถึง J8

Code: Select all

Sub Run()
'
' Run Macro
'

'
    Range("A3:L4").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Range("A3").Select
    ActiveSheet.Paste
    Range("C11").Select
    Sheets("Data").Select
    Range("U4:V4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A2").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C9").Select
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Mr.Manit"
    Range("C10").Select
    Sheets("Data").Select
    Range("A3:J5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("I10").Select
    Sheets.Add After:=ActiveSheet
    Range("A3").Select
    ActiveSheet.Paste
    Rows("4:4").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("E7").Select
    Sheets("Data").Select
    Range("U5:V5").Select
    Selection.Copy
    Range("I11").Select
    Sheets("Sheet3").Select
    Range("A2").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C7").Select
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "Mr.Pravit"
    Range("C11").Select
    Sheets("Data").Select
    Range("A3:L6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("H15").Select
    Sheets.Add After:=ActiveSheet
    Range("A3").Select
    ActiveSheet.Paste
    Rows("4:5").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("E7").Select
    Sheets("Data").Select
    Range("U6:V6").Select
    Selection.Copy
    Range("D16").Select
    Sheets("Sheet4").Select
    Range("A2").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B8").Select
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "Mr.Ratch"
    Range("C13").Select
    Sheets("sheet").Select
    Range("E9").Select
    
        Range("A3:L3").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Range("A3").Select
    ActiveSheet.Paste
    Range("C6").Select
    Sheets("Data").Select
    Range("A7:L8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("F19").Select
    Sheets("Sheet2").Select
    Range("A4").Select
    ActiveSheet.Paste
    Range("G6").Select
    Sheets("Data").Select
    Range("U7:V7").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Mr.Yoth"
    Range("D10").Select
    Sheets("Data").Select
    Range("F14").Select
    Application.CutCopyMode = False
    Range("D10").Select
End Sub

[snasui]

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

Code: Select all

Sub Test0()
    Dim users As Object, rng As Range, itm As Variant
    Dim arr As Variant, l As Long, m As Integer, i As Integer
    Dim arri(1 To 99, 1 To 12) As Variant, sh As Worksheet
    
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If sh.Index > Worksheets("Data").Index Then
            sh.Delete
        End If
    Next sh
    Application.DisplayAlerts = True
    Set users = CreateObject("Scripting.Dictionary")
    With Worksheets("Data")
        arr = .Range("a4", .Range("v" & .Rows.Count).End(xlUp))
    
        For Each rng In .Range("v4", .Range("v" & .Rows.Count).End(xlUp))
            If Not users.exists(rng.Offset(0, -1).Value & "_" & rng.Value) Then
                users.Add rng.Offset(0, -1).Value & "_" & rng.Value, rng.Value
            Else
                Exit For
            End If
        Next rng
    
        l = 1
        For Each itm In users
            Erase arri
            m = 1
            For i = 1 To UBound(arr, 1)
                If itm = arr(i, 21) & "_" & arr(i, 22) Then
                    For k = 1 To 12
                        arri(m, k) = arr(i, k)
                    Next k
                    m = m + 1
                End If
            Next i
            Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            With sh
                .Name = VBA.Split(VBA.Split(itm, "_")(1), " ")(0)
                .Range("a2:b2").Value = VBA.Split(itm, "_")
                .Range("a3:l3").Value = Worksheets("Data").Range("a3:l3").Value
                .Range("a4").Resize(m, 12).Value = arri
                Worksheets("Data").Range(.Range("a3").CurrentRegion.Address).Copy
                .Range("a3").CurrentRegion.PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
        Next itm
    End With
End Sub

[March201711]

อาจารย์ค่ะ รันได้อย่างที่อาจารย์ให้มาค่ะ แต่พอดิฉันเพิ่มรายชื่อลูกค้าเพิ่มตามที่ high light สีเหลืองแล้ว ทำไมไม่แยกลูกค้าที่เหลือแบ่งออกแต่ละชีทคะ เช่น Mr.Wanphen, Ms.Pornjun.ไปจนถึง Mr.Surin ถึงลูกค้าบรรทัดที่ 21 คะ

[snasui]

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

Code: Select all

'Other code
For Each rng In .Range("v4", .Range("v" & .Rows.Count).End(xlUp))
    If rng.Value = "" Then
        Exit For
    ElseIf Not users.exists(rng.Offset(0, -1).Value & "_" & rng.Value) Then
        users.Add rng.Offset(0, -1).Value & "_" & rng.Value, rng.Value
    End If
Next rng
'Other code

[March201711]

Q:ถ้าวันรุ่งขึ้น มีข้อมูลของวันถัดไปต่อมา อยากให้รันข้อมูลต่อจาก sheet เดิมที่เคยมีชื่อลูกค้าอยู่ก่อนแล้วต่อข้อมูลลงไป ถ้าไม่มีชื่อลูกค้ารายใหม่ให้เพิ่ม sheet ถัดไปค่ะ
เช่น Mr.Supachai ไม่เคยมีชื่อ sheet ลูกค้ารายใหม่มาก่อน อยากให้รันเพิ่มชื่อsheet นี้ใหม่ เป็น Mr.Supachai
เช่น Ms.Kaesorn เคยมีsheet ลูกค้ารายนี้แล้ว ให้รันข้อมูลต่อจากวันก่อนที่ sheet Ms.Kaesorn (high light สีเหลือง)
เช่น Mr.Satipaj เคยมีsheet ลูกค้ารายนี้แล้ว ให้รันข้อมูลต่อจากวันก่อนที่ sheet Mr.Satipaj (high light สีเหลือง)

[snasui]

กรุณาปรับ Code มาเองก่อน หากปรับมาแล้วช่วยแจ้งว่าปรับเป็นแบบไหน อย่างไร ติดขัดขั้นตอนไหน จะได้ตอบต่อไปจากนั้นครับ

[March201711]

ลองทำแล้วได้แบบนี้ค่ะ

Code: Select all

Sub NextDay()
'
' NextDay Macro
'

'
    Range("A3:L4").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Range("A3").Select
    ActiveSheet.Paste
    Range("D8").Select
    Sheets("Data").Select
    Range("U4:V4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("F16").Select
    Sheets("Sheet1").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B9").Select
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Mr.Supachai"
    Range("E19").Select
    Sheets("Data").Select
    Range("A3:L5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G17").Select
    Sheets.Add After:=ActiveSheet
    Range("A3").Select
    ActiveSheet.Paste
    Range("B10").Select
    Sheets("Data").Select
    Range("U5:V5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("D17").Select
    Sheets("Sheet2").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("4:4").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("B9").Select
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Mr.Aphichai"
    Sheets("Data").Select
    Range("B6:J6").Select
    Selection.Copy
    Range("F19").Select
    Sheets("Ms.Kaesorn").Select
    Range("B5").Select
    ActiveSheet.Paste
    Range("F9").Select
    Sheets("Data").Select
    Range("A6:L6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Ms.Kaesorn").Select
    Range("A5").Select
    ActiveSheet.Paste
    Range("F8").Select
    Sheets("Data").Select
    Range("E18").Select
    Application.CutCopyMode = False
End Sub

[snasui]

ช่วยตอบให้ตรงกับที่แจ้งไปในโพสต์ #8 ครับ

Code ที่ผมปรับไปนั้นจะมีการลบชีตหากมีอยู่เดิม แล้วสร้างชีตใหม่ตามรายชื่อที่มีทุกครั้งที่มีการคลิกให้ Code ทำงาน หากไม่มีรายชื่อก็จะไม่มีการสร้างชีตขึ้นมาให้ จะไม่มีการสร้างชีตเอาไว้ล่วงหน้าแล้วค่อยนำข้อมูลไปวางหรือลบข้อมูลออก สามารถตรวจสอบความครบถ้วนของข้อมูลหลังจากทำงานตามคำสั่งแล้ว

ที่โพสต์มาไม่เรียกว่าปรับแต่เป็นการบันทึก Macro ใหม่ ซึ่งปัจจุบันผ่านขึ้นตอนนั้นไปแล้วจะไม่ย้อนกลับไปอีก

หรือหากการบันทึก Macro นั้นใช้แทน Statement ใด ๆ ในโพสต์ #4 และ #6 กรุณาแจ้งมาโดยละเอียดในช่องความเห็นนี้เสมอว่าบันทึกแทน Statement ใด ติดขัดตรงไหน อย่างไร หากมีเขียนเพิ่มเติมไว้ไฟล์ก็ควรอ้างอิงประกอบเข้ามาด้วย

กรุณาทราบว่าผมจะตอบจากที่คุณ March201711 ได้ปรับ Code ที่ผมตอบไปในครั้งก่อนเท่านั้น จะไม่ย้อนไปเขียนใหม่ตั้งแต่เริ่มต้นครับ

[March201711]

ขอบคุณค่ะอาจารย์ code ของอาจารย์ใชได้ดีเลยค่ะ แต่คิดกลับไปในวันถัดไปมันจะลบข้อมุลเดิมทิ้งค่ะ
ถ้าจะใช้ formula มาช่วยปรับเพ่ิมให้ดึงรายชื่อลูกค้าจาก sheet data แต่ติดว่าข้อมูลที่ดึงมาบรรทัดซ้ำกับข้อมูลแรก ในกรณีที่มีขื่อลูกค้าคนเดียวทำ 2 รายการ บางครั้งก็ทำ 3 -5 บรรทัด ข้อมุลที่ดึงมาจะซ้ำๆกันกับข้อมูลแรก ต้องปรับสูครอย่างไรคะ

[snasui]

ไม่จำเป็นต้องใช้อะไรช่วยอีก แค่ Run ซ้ำมันก็นำข้อมูลมาแสดงใหม่ Code ที่ปรับให้ไปสามารถรันซ้ำได้ตามต้องการ ไม่ใช่ Run ครั้งแรกแล้วต้องมาเติมข้อมูลเองที่ชีตต่าง ๆ ในภายหลังแต่อย่างใด

ไม่ทราบว่าได้ลอง Run ซ้ำแล้วหรือไม่ ติดขัดตรงไหน ประการใดครับ

[March201711]

รัน marco อย่างที่อาจารย์ให้ไม่ติดเลยค่ะ แต่ติดตรงที่ถ้าข้อมูลรายชื่อลูกค้าเยอะๆเป็น 20-30 คนต่อวัน มีรายการเยอะกว่า 20 รายการต่อคน ถ้าใช้marco run บางครั้ง error บ่อยค่ะ บางครั้ง ไฟล์เสีย savve ไม่ได้ code marco หายค่ะ ไม่ทราบเกิดจากอะไรแต่มี sheet อื่นรวมอยู่ด้วยนอกจาก sheet ลูกค้า คงเป็นเพราะ sheet มากมีเป็น 100 กว่าชีทค่ะ อาจารย์

[snasui]

ไม่สามารถตอบได้ว่า Error ที่แจ้งมาเกิดจากสาเหตุใด ปกติในการ Run Code ถ้ามีปัญหามันจะต้องแจ้งขึ้นมา

เพื่อป้องกันไฟล์เสียหายจนไม่สามารถกู้คืนได้ ควรทำการ Backup ไฟล์เอาไว้เสมอครับ

[March201711]

ค่ะ ถ้าเปลี่ยนใช้ formula จะไม่ค่อยเกิดปัญหาค่ะ อยากใช้แบบสูตรจะได้แก้ไขเองได้ อย่าง code marco เกิดปัญหาทีไม่รุ้ว่าจะแก้ยังงัยค่ะ

[snasui]

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

ชีต Mr.Nuntana เซลล์ A4 คีย์

=IFERROR(INDEX(Data!A:A,AGGREGATE(15,6,ROW(Data!$A$4:$A$102)/($A$2=Data!$U$4:$U$102),ROWS(A$4:A4))),"")

Enter > Copy ไปด้านขวาและลงด้านล่าง > ปรับใช้กับชีตอื่น ๆ

[March201711]

ได้แล้วค่ะ ขอบคุณอาจารย์มากค่ะ