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

[วังวู ช่ง]

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

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("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
        
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete shift:=xlUp
    Application.ScreenUpdating = True
End Sub

[snasui]

ที่เซลล์ O10 เปลี่ยนสูตรเป็น

=SUBTOTAL(9,O12:O28)

Enter > Copy ไปทางขวา อย่าลืมปรับช่วงในสูตรในตรงกับช่วงข้อมูลจริง

จากนั้น ลองปรับ Code มาดูก่อนครับ แนบ Code ที่ปรับมาเองแล้วมาด้วยครับ

[วังวู ช่ง]

ที่เซลล์ O10 เปลี่ยนสูตรเป็น

=SUBTOTAL(9,O12:O28)

Enter > Copy ไปทางขวา อย่าลืมปรับช่วงในสูตรในตรงกับช่วงข้อมูลจริง
จากนั้น ลองปรับ Code มาดูก่อนครับ แนบ Code ที่ปรับมาเองแล้วมาด้วยครับ

ได้คำตอบที่ต้องกานแล้วครับส่วน ผมจะลองปรับ Code ก่อนครับ เพราะมีบ่อนเช็นอีกที่ก้องตาราง 5 บ่อนเช็นครับแบบนี้ครับ (ตามไฟล) ครับ

[วังวู ช่ง]

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

Code: Select all

Sub Sep()
Dim header As Range
Dim signature As Range

Sheets("ListEx").Range("AH:BZ").Clear
Set header = Range("A1:AG11")
Set signature = Sheets("Nsch").Range("H2:AN3")

srcRowNum = Sheets("List").Range("G" & Rows.Count).End(xlUp).Row
For itemRw = 12 To srcRowNum
If WorksheetFunction.CountIf(Range("G12:G" & itemRw), Cells(itemRw, "G").Value) = 1 Then
Cells(itemRw, "AH") = WorksheetFunction.Max(Range("AH:AH")) + 1
End If
Next itemRw

numOfItem = WorksheetFunction.Max(Range("AH:AH"))
For itemNo = 1 To numOfItem
selItem = Range("G" & WorksheetFunction.Match(itemNo, Range("AH:AH"), 0)).Value
targetRow = Range("AI" & Rows.Count).End(xlUp).Row + 10
header.Copy
Range("AI" & targetRow).PasteSpecial xlPasteAll
For Each sameItem In Range("G12:G" & srcRowNum)
If sameItem = selItem Then
Range("A" & sameItem.Row & ":AG" & sameItem.Row).Copy
Range("AI" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End If
Next sameItem
firstRwSameItem = targetRow + 11
LastRwSameItem = Range("AI" & Rows.Count).End(xlUp).Row
fmlRw1 = targetRow + 9
fmlRw2 = targetRow + 10
For fmlCol = 49 To 66
Cells(fmlRw1, fmlCol) = WorksheetFunction.Sum(Range(Cells(firstRwSameItem, fmlCol).Address & ":" & Cells(LastRwSameItem, fmlCol).Address))
Cells(fmlRw2, fmlCol) = Cells(fmlRw1, fmlCol) * 3
Next fmlCol
Sheets("ListEx").Range("BL" & targetRow + 4).FormulaR1C1 = "=VLOOKUP(R[7]C[-23],name,2,0)"
signature.Copy
Sheets("ListEx").Range("AI" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Next itemNo
    Columns("AH:AH").Select
    Selection.ClearContents
    Range("AI1:BO10").Select
    Selection.Delete Shift:=xlUp
    Range("AI1:BO1").Select
End Sub

[snasui]

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

[วังวู ช่ง]

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

[snasui]

ครับผม อ่านที่นี่เพิ่มเติมด้วยครับ viewtopic.php?f=5&t=2806

[วังวู ช่ง]

ที่เซลล์ O10 เปลี่ยนสูตรเป็น

=SUBTOTAL(9,O12:O28)

Enter > Copy ไปทางขวา อย่าลืมปรับช่วงในสูตรในตรงกับช่วงข้อมูลจริง

จากนั้น ลองปรับ Code มาดูก่อนครับ แนบ Code ที่ปรับมาเองแล้วมาด้วยครับ

ขอโทษมากครับ ท่าน อาจารย์ครับ ผมปรับแล้วแต่ปรับไม่เป็นเลียครับช่วยดู และปรับให้ด้วยครับคือ
1. คำตอบใน AT10:BN10 ไม่ตรงกับความต้องการ
2. คำตอบใน BM7:BO7... ไม่ตรงกรับความต้องกาน
ขอบคุณล่วงหน้า

[snasui]

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

Code: Select all

Sub Macro2()
    Application.ScreenUpdating = False
    
    Range("A1:AG11").Select
    Selection.Copy
    Range("AI1:BO1").Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    Dim rAll As Range, r As Range
    Dim rSource As Range
    Dim lRow1 As Long, lRow2 As Long
    Dim header As Range

    
    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 Signature = Sheets("name").Range("H2:AN3")
        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 + 10 '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" & lRow).Resize(11, 33) = .Range("AI" & lRow).Resize(11, 33).Value 'Add this line
    .Range("AI" & lRow2).Resize(, 33).Delete shift:=xlUp
    End With
    
    targetRow = Range("AI" & Rows.Count).End(xlUp).Row + 10
    Sheets("List").Range("BL" & targetRow + 7).FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"
    Signature.Copy
    Sheets("List").Range("AI" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
    
    Next r
    Range("AH:AH").Clear
    Range("A12:AG12").Delete shift:=xlUp
    
        Range("A1:AG11").Select
        Selection.Copy
        Range("AI1:BO1").Select
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Range("AI1:BO1").Select
        Application.CutCopyMode = False

    Application.ScreenUpdating = True
End Sub

[วังวู ช่ง]

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

Code: Select all

    Sheets("List").Range("BL" & targetRow + 7).FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"

[/quote]

[วังวู ช่ง]

เรียนท่าน อาจารย์ที่เคารบครับ ติดป้ญหานิดหน่อยตรงด้านด่างนี้ครับ ทำงานไม่ได้ตามต้องกานครับ ถ้าไม่เป็นกานรบกวนมากช่วยปรับให้หน่อยครับ จิงๆแล้วผมต้องกานทำอย่างนี้ครับ
BM7:BO7=VLOOKUP(AO12,name,2,0)
BM64:BO64=VLOOKUP(AO69,name,2,0)
.
.
.
.
.
ขอบคุณล่วงหน้าครับ

Code: Select all

    Sheets("List").Range("BL" & targetRow + 7).FormulaR1C1 = "=VLOOKUP(R[5]C[-23],name,2,0)"

[/quote]

[snasui]

ไม่เข้าใจครับ ต้องการจะทำอะไร ปัญหาคืออะไร ต้องการผลลัพธ์เป็นอย่างไรครับ

[วังวู ช่ง]

ไม่เข้าใจครับ ต้องการจะทำอะไร ปัญหาคืออะไร ต้องการผลลัพธ์เป็นอย่างไรครับ

ผมลองทำก่อนเป็นไงจะแจ้งให้อีกทีครับ