เขียน VBA แยกหมวดสินค้า

วังวู ช่ง · #1

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

ผมเขียน VBE ไม่เป็นจิงๆครับ ขอช่วยเหลือด้วยครับ ขอบคุณทุกท่านที่มีน้ำใจสัดทาช่วยเหลือครับ

snasui · #2

สำหรับ VBA แล้ว ลองเขียนมาก่อนเท่าที่ทำได้เหมือนเช่นที่ผ่าน ๆ มาครับ ติดตรงไหนค่อยมาดูกันต่อ

ขอให้แจ้งด้วยว่า Code อยู่ที่ Module ใด ชื่อ Procedure อะไร จะได้เข้าถึงข้อมูลได้โดยไวครับ

วังวู ช่ง · #3

เรียน ท่านอาจารย์ ที่เคาลบครับ ผมแกะโคดของเขามาใช้ แต่ผนตอบไม่ตงกับความต้องกานครับ ลองช่วยดูด้วยครับ

สำคันให้ท่าน อาจารย์ ดัดปับเวลาข้อมูนมีกานเปรี่ยนแปงครับ โคดที่ทำนี้ใช้ไ้ด้แค่ ถึง row24 ครับ

ขอบคุณ ท่าน อาจารย์ ล่วงหน้าครับ

snasui · #4

ลองดูตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Sub Macro1()
    Dim rAll As Range, r As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    Range("D1:XFD" & Rows.Count).Clear
    Range("B:B").Copy Range("D:D")
    Range("D:D").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("D1:D3").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("D5", .Range("D" & Rows.Count).End(xlUp))
     End With
    For Each r In rAll
        Range("D2").Formula = "=B2=" & r
        Range("A:C").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            Range("D1:D2"), CopyToRange:=Range("E1").Offset(0, i)
        i = i + 4
    Next r
    Range("D:D").Clear
    Application.ScreenUpdating = True
End Sub

วังวู ช่ง · #5

เรียน ท่าน อาจารย์ ที่เคาลบครับ ได้แล้วครับ ขอบคุณมากครับ

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

ขอบคุณท่านอาจารย์มากครับ

โชกดีครับ

snasui · #6

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

ผมปรับ Code มาเป็นตัวอย่างตามด้านล่างครับ

Code: Select all

Sub Macro2()
    Dim rAll As Range, r As Range
    Dim rSource As Range, i As Integer
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Clear
    Range("A12:AG12").Insert Shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
     End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
        With ActiveSheet
            rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            .Range("AH11:AH12"), CopyToRange:=.Range("AI11").Offset(0, i)
            .Range("AI1").Offset(0, i).Resize(11, 33) = .Range("A1:AG11").Value
            i = i + 34
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete Shift:=xlUp
    Application.ScreenUpdating = True
End Sub

วังวู ช่ง · #7

เรียน ท่าน อาจารย์ ที่เคาลบครับ ขอลบกวนท่านหน่อยครับ ขอความช่วยเหลือครับ

บันหาคืว่า ในไฟลล์ที่แนบมานี้ ทำมะมี 40 หน้าที่ต้องกานครับ แต่เมื่อ Print Preview แล้วมีทังหมด 432 หน้าครับ จะแก้ไขตงไหนครับ

เรียนท่าน อาจารย์ ช่วยดูหน่อย แล้วดัดปับให้ผมด้วยครับ

ขอบคุณมากครับ

ขออาไพ ขหนาดไฟลล์มากครับ

snasui · #8

ควรกำหนดพื้นที่ในการ Print เพื่อให้ Excel รับรู้ว่าต้องการที่จะ Print พื้นที่ใดก่อนครับ โดย

คลุมพื้นที่ที่จะ Print
กำหนดตามภาพด้านล่าง

วังวู ช่ง · #9

เรียน ท่าน อาจารย์ ที่เคาลบครับ พอมีวิทีอื่นไม่ครับ ที่สามาด Select ส่วนที่ต้องกาน Print ทังหมด แล้วจึ่ง Set Print Area

เพาะผมลำบากมากในกานที่ กด Ctrl แล้วค่อยมา Select ที่ละอย่าง จากนั้นจึ่ง Set Print Area ครับ พอมีวิทีอื่นที่ Select ง่ายกว่าย่างที่ผมทำ มาแนะนำให้ผมครับ

ขอบคุณมากครับ

snasui · #10

การเลือกพื้นที่มาก ๆ หลาย ๆ พื้นที่สามารถทำตามด้านล่างครับ

กดแป้น F5
ทำตามภาพด้านล่าง

สังเกตว่าในช่อง Reference: สามารถกรอกเซลล์หรือช่วงเซลล์ได้ตามต้องการ

วังวู ช่ง · #11

เรียน ท่าน อาจารย์ ครับ ถ้าผมต้องกานให้เป็นลวงตั้งจะปรับ Code นี้อย่างไลครับ ช่วยปรับให้ด้วยครับ
ขอบคุณล่วงหน้าครับ

Code: Select all

Sub Macro2()
    Dim rAll As Range, r As Range
    Dim rSource As Range, i As Integer
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Clear
    Range("A12:AG12").Insert Shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
     End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
        With ActiveSheet
            rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            .Range("AH11:AH12"), CopyToRange:=.Range("AI11").Offset(0, i)
            .Range("AI1").Offset(0, i).Resize(11, 33) = .Range("A1:AG11").Value
            i = i + 34
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete Shift:=xlUp
    Application.ScreenUpdating = True
End Sub

snasui · #12

ลองปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Sub Macro2()
    Dim rAll As Range, r As Range
    Dim rSource As Range
    Dim lRow1 As Long, lRow2 As Long
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Clear
    Range("A12:AG12").Insert Shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert Shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
     End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
        With ActiveSheet
            If .Range("AI1") = "" Then
                lRow = 1
            Else
                lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
            End If
            .Range("AI" & lRow).Resize(11, 33) = .Range("A1:AG11").Value
            lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
            rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
            .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete Shift:=xlUp
    Application.ScreenUpdating = True
End Sub

วังวู ช่ง · #13

ขอบคุณท่าน อาจารย์ มากครับ ยังติดปัญหาน้อยหนึ่งครับคือมันแสดง
Col1 Col2 Col3 Col4 Col5 Col6 Col7 Col8 Col9 Col10 Col11 Col12 Col13 Col14 Col15 Col16 Col17 Col18 Col19 Col20 Col21 Col22 Col23 Col24 Col25 Col26 Col27 Col28 Col29 Col30 Col31 Col32 Col33
ผมไม่อยากให้แสดงจะปรับอย่างไลครับ
และรบกวนท่านอาจารย์ช่วยปรับ Code ลุ่มนี้ให้ด้วยครับ ปัญหาคือถ้าข้อมูนมากกว่านี้จะหยุ้งมากครับ และที่ก้องของทุกตารางมีบ่อนเชันของพากส่วนต่างๆตาม File ครับ

Code: Select all

Sub FormatPainter()
    Range("A1:AG11").Select
    Selection.Copy
    Range("AI1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI21").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI40").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI57").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI77").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI97").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AI1:BO1").Select
End Sub

ขอบคุณท่านอาจารย์ล่วงหน้าครับ

snasui · #14

ลองปรับเป็นด้านล่างครับ

Code: Select all

'Other code
With ActiveSheet
    If .Range("AI1") = "" Then
        lRow = 1
    Else
        lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
    End If
    .Range("AI" & lRow).Resize(11, 33) = .Range("A1:AG11").Value
    lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
    rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
'Other code
End With

'Other code

snasui · #15

วังวู ช่ง wrote:และรบกวนท่านอาจารย์ช่วยปรับ Code ลุ่มนี้ให้ด้วยครับ ปัญหาคือถ้าข้อมูนมากกว่านี้จะหยุ้งมากครับ และที่ก้องของทุกตารางมีบ่อนเชันของพากส่วนต่างๆตาม File ครับ

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

วังวู ช่ง · #16

snasui wrote:
วังวู ช่ง wrote:และรบกวนท่านอาจารย์ช่วยปรับ Code ลุ่มนี้ให้ด้วยครับ ปัญหาคือถ้าข้อมูนมากกว่านี้จะหยุ้งมากครับ และที่ก้องของทุกตารางมีบ่อนเชันของพากส่วนต่างๆตาม File ครับ
ลองปรับมาเองดูก่อนครับ ปกติผมจะปรับเฉพาะที่ติดปัญหา Code ที่ใช้การได้แล้วถือว่าไม่ได้เป็นปัญหา ไม่ว่ามันจะสั้นหรือยาวอย่างไรก็ตาม

เรียนท่าน อาจารย์รครับ Code นี้ผมได้จากการ Record Macro สามาด Format Painter ได้แต่ 6 ตารางครับ จริงๆแล้วมากกว่านี้ครับ

Code: Select all

Sub FormatPainter()
    Range("A1:AG11").Select
    Selection.Copy
    Range("AI1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI20").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI38").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI54").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI73").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("AI92").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AI1:BO1").Select
End Sub

snasui · #17

ศึกษาการ Looping จากตัวอย่างที่ผมเคยเขียนให้ไปหรือจากตัวอย่างในฟอรัมนี้ซึ่งมีจำนวนมาก เพื่อดูว่ามีหลักการ Loop อย่างไร แล้วปรับมาดูกัน ได้เท่าไรก็เท่านั้น ลำพังบันทึก Macro อย่างเดียวไม่อาจช่วยได้สำหรับข้อมูลที่เป็น Dynamic ครับ

วังวู ช่ง · #18

snasui wrote: ศึกษาการ Looping จากตัวอย่างที่ผมเคยเขียนให้ไปหรือจากตัวอย่างในฟอรัมนี้ซึ่งมีจำนวนมาก เพื่อดูว่ามีหลักการ Loop อย่างไร แล้วปรับมาดูกัน ได้เท่าไรก็เท่านั้น ลำพังบันทึก Macro อย่างเดียวไม่อาจช่วยได้สำหรับข้อมูลที่เป็น Dynamic ครับ

ขอบคุณท่าน อาจารย์ครับ ผมลองดูก่อนอย่างไลจะมาแจ้งให้อีกทีครับ

วังวู ช่ง · #19

เรียนท่าน อาจารย์ครับ รบกวนอีกครับ ผมพะยายามทำแต่ทำไม่ได้ครับ ช่วยปรับให้ด้วยครับ คือว่าผนออกมาอยากให้เหมือนตารางเดีมครับเชั่น AI1:BO11,AI20:BO30,AI38:BO48,AI54:BO64,AI73:BO83,AI92:BO102.....อยากให้เหมือนกับ A1:AG11 ครับ ตัวอย่างที่ต้องกาน เรียนท่านอาจารย์ดูที่ ListEx ครับ ขอบคุณอย่างสูงครับ
ด้วยความที่เคารบ และนับถื

Code: Select all

Sub Macro1()
    Dim rAll As Range, r As Range
    Dim rSource As Range
    Dim lRow1 As Long, lRow2 As Long
    Application.ScreenUpdating = False
    Range("AH1:XFD" & Rows.Count).Delete
    Range("A12:AG12").Insert shift:=xlDown
    Range("A12:AG12").Select
    Range("A12") = "Col1"
    Range("A12").AutoFill Destination:=Range("A12:AG12"), Type:=xlFillDefault
    Range("G:G").Copy Range("AH:AH")
    Range("AH:AH").UnMerge
    Range("AH:AH").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("AH1:AH13").Insert shift:=xlDown
    With ActiveSheet
        Set rAll = .Range("AH18", .Range("AH" & Rows.Count).End(xlUp))
        Set rSource = .Range("A12", .Range("A" & Rows.Count).End(xlUp)).Resize(, 33)
    End With
    For Each r In rAll
        Range("AH12").Formula = "=G13=" & r
    With ActiveSheet
    If .Range("AI1") = "" Then
        lRow = 1
    Else
        lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
    End If
    .Range("AI" & lRow).Resize(11, 33) = .Range("A1:AG11").Value
    lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
    rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
        End With
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete shift:=xlUp
    Application.ScreenUpdating = True
End Sub

snasui · #20

ผม Run ได้เป็นปกติครับ ไม่ติดปัญหาใดครับ ส่วนที่เป็นตารางจำเป็นต้องปรับ Code มาเอง ติดตรงไหนค่อยมาถามกันครับ

หากเพียงแต่ Copy หัวตารางมาใช้ทั้งค่าและรูปแบบ สามารถปรับ Code เป็นด้านล่างครับ

Code: Select all

'Other code
With ActiveSheet
    If .Range("AI1") = "" Then
        lRow = 1
    Else
        lRow = .Range("AI" & Rows.Count).End(xlUp).Row + 5 'Change 5 to the value what you want
    End If
    .Range("A1:AG11").Copy .Range("AI" & lRow).Resize(11, 33)
    lRow2 = .Range("AI" & Rows.Count).End(xlUp).Row + 1
    rSource.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("AH11:AH12"), CopyToRange:=.Range("AI" & lRow2)
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
End With
'Other code

Snasui Excel Forum

File Anatomy Add-in: แก้ปัญหาไฟล์ Excel ช้า แฮงก์ และไม่เสถียร อย่างมืออาชีพ

เขียน VBA แยกหมวดสินค้า

เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า

Re: เขียน VBA แยกหมวดสินค้า