ต้องการให้ข้อมูลจัดกลุ่มโดยใช้ VBA

[akekorn]

รบกวนคุณคนควน ช่วยทำต่อให้ทีนะครับ เพราะผมเขียน VBA แล้ว แต่มันยังได้ช่องไม่ตรงทั้งหมดเลยขอความกรุณาช่วยผมด้วยครับ
ขอบคุณครับ

[snasui]

ลองทดสอบดู Code ตามด้านล่างครับ

Code: Select all

Sub TransposePaste()
Dim Int1 As Integer, Int2 As Integer
Dim Int3 As Integer
Dim rRange1 As Range
Dim rRange2 As Range, rRange3 As Range
    With ActiveSheet
        .Range("E:IV").ClearContents
        .Range("A:A").Copy
        .Range("E:E").PasteSpecial xlPasteValues
        .Range("E:E").RemoveDuplicates Columns:=1, Header:=xlNo
        .Range("E1").ClearContents
        Set rRange2 = .Range("E2", .Range("E65536").End(xlUp))
    End With
    For Each rRange1 In rRange2
        Int3 = Application.WorksheetFunction. _
            Match(rRange1, Range("A:A"), 0)
        Int2 = Application.WorksheetFunction. _
            CountIf(Range("A:A"), rRange1)
        Set rRange3 = Range("A1").Offset(Int3 - 1, 1).Resize(Int2, 1)
        rRange3.Copy
        rRange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Next
    Application.CutCopyMode = False
    MsgBox "Fish"
End Sub

[akekorn]

คือผมลองวาง code แล้วปรากฏว่า run แล้วเกิด error object doesn't support this property or method
ที่บรรทัด
.Range("$E$1:$E$555").RemoveDuplicates Columns:=1, Header:=xlNo

รบกวนคุณคนควนช่วยให้อีกทีครับ
ขอบคุณครับ

[snasui]

กรณีใช้ Excel 2003 ลองตาม Code ด้านล่างครับ

Code: Select all

Sub TransposePaste()
Dim Int1 As Integer, Int2 As Integer
Dim Int3 As Integer
Dim rRange1 As Range
Dim rRange2 As Range, rRange3 As Range
    With ActiveSheet
        .Range("E:IV").ClearContents
        .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "E1"), Unique:=True
        .Range("E1").ClearContents
        Set rRange2 = .Range("E2", .Range("E65536").End(xlUp))
    End With
    For Each rRange1 In rRange2
        Int3 = Application.WorksheetFunction. _
            Match(rRange1, Range("A:A"), 0)
        Int2 = Application.WorksheetFunction. _
            CountIf(Range("A:A"), rRange1)
        Set rRange3 = Range("A1").Offset(Int3 - 1, 1).Resize(Int2, 1)
        rRange3.Copy
        rRange1.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Next
    Application.CutCopyMode = False
    MsgBox "Finish"
End Sub

[akekorn]

ขอบคุณมากครับสุดยอดเลยครับ ว่าแต่ code ข้างบนนี่ต้องเป็น excel 2007 ขึ้นไปใช่ไหมครับ

[snasui]

Code ชุดแรกใช้กับ Excel 2007 ขึ้นไปครับ เป็นการหา Unique Item ได้เลย แต่หากเป็น 2003 ลงมาต้องใช้ Advanced Filter มาช่วยหา Unique Item ครับ