ถาม Code VBA กำหนด Range ข้าม Sheet

[chom_poona]

สวัสดีค่ะ

รบกวนสอบถามคำสั่ง VBA หน่อยค่ะว่า ถ้าเราสร้างข้อมูล (Range) ไว้ที่ Sheet หนึ่ง แล้ว ต้องการให้ ผลลัพธ์มาแสดงอีก Sheet หนึ่ง
ใช้คำสั่งอะไรค่ะ

ขอ คำสั่งการกำหนด Range ข้าม Sheet ด้วยค่ะ

ตัวอย่าง ที่ส่งมาให้ ดู เป็น Whit ActiveSheet ซึ่ง ข้อมูลอยู่ใน Sheet เดียวกัน

[chom_poona]

แนบไฟล์ไม่ได้ค่ะ

[logic]

ตัดไฟล์ให้เล็กลงก่อนครับ ขนาดไม่เกิน 300kb ครับ

[chom_poona]

Sub Button1_Click()
Dim rall As Range, icount As Long
Dim r1 As Range, r2 As Range
Dim c As New Collection, item As Variant
With ActiveSheet
Set rall = Union(.[b3:e5], .[b19:e24]) 'select Range
.Range("j6:j1000,o6:o1000").ClearContents 'Clear Range
For Each r1 In rall 'loop Range rall1
icount = 0
For Each r2 In rall 'loop range rall2

อยากกำหนด Range ไว้อีก Sheet ตรง Set rall ต้องกำหนดยังไงค่ะ
ไฟล์ แค่ 16 kb แนบไฟล์แล้วให้ใส่ password

[logic]

เรื่อง vba ทำตามกฎข้อ 5 ด้วยครับ

[chom_poona]

Code: Select all

Sub check()
Dim rall As Range, icount As Long
Dim r1 As Range, r2 As Range
Dim c As New Collection, item As Variant
With ActiveSheet
    Set rall = Union(.[b5:f21], .[j5:n21], .[r5:v21], .[z5:ad21], .[ah5:al21]) 'select Range
    .Range("b6:b1000,p6:p1000").ClearContents 'Clear Range
    For Each r1 In rall  'loop Range rall1
        icount = 0
        For Each r2 In rall 'loop range rall2
            If r1.Value = r2.Value Then
                icount = icount + 1
            End If
        Next r2
        On Error Resume Next 'if error run on
        If icount > 1 Then
            c.Add CStr(r1.Value), CStr(r1.Value) ' add value collection(item)
        End If
        On Error GoTo 0
    Next r1
    For Each item In c
        If CLng(item) <= .[b2] Then
            .Range("j" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        Else
            .Range("o" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        End If
    Next item
End With
'sort roll k
ActiveWorkbook.Worksheets("test").sort.SortFields.Clear
ActiveWorkbook.Worksheets("test").sort.SortFields.Add Key:=Range("c6:c100"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("test").sort
    .SetRange Range("b6:n100")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

[chom_poona]

รบกวนแก้ไข code ให้ ด้วยค่ะ
ในกรณีที่ Range อยู่ กันคนละ Sheet ค่ะ

[snasui]

Code ที่จะให้แก้ต้องเขียนมาเอง ไม่ใช่เป็น Code เดิมที่ยังไม่มีการแก้ไขใด ๆ

ลองแนบไฟล์พร้อม Code ที่ลองแก้เองแล้วมาใหม่ กรณีหลุดออกจากระบบให้ Login เข้ามาใหม่แล้วค่อยแนบไฟล์ครับ

[chom_poona]

เรื่องการ กำหนด Range ข้าม Sheet สามารถทำได้แล้วค่ะ

แต่ว่า ข้อมูลที่ต้องการให้มาแสดงยังไม่ถูกต้อง ไม่รู้ว่า ใช้คำสั่งผิดตรงไหนค่ะ

รบกวนผู้รู้ช่วยตอบหน่อยค่ะ ตามตัวอย่างไฟล์ที่แนบมาให้ค่ะ

แก้ไข** พบว่า vba ไม่แสดงค่า ตัวเลขที่เป็นทศนิยม 2 ตำแหน่งค่ะ

[chom_poona]

Code: Select all

Sub check()
Dim rall As Range, icount As Long
Dim r1 As Range, r2 As Range
Dim c As New Collection, item As Variant
With Sheets("cal")
    Set rall = Union(.[b5:f21], .[b31:h49], .[x31:ac49], .[j5:n21], .[r5:v21], .[z5:ad21], .[m31:s49], .[ag31:al49], .[ah5:al21], .[ap5:at21], .[ao29:at36]) 'select Range

    With Sheets("Result")
    .Range("c6:c1000,q6:q1000").ClearContents
    For Each r1 In rall
        icount = 0
        For Each r2 In rall
            If r1.Value = r2.Value Then
                icount = icount + 1
            End If
        Next r2
        On Error Resume Next
        If icount > 1 Then
            [b]c.Add CDbl(r1.Value), CDbl(r1.Value)[/b]
        End If
        On Error GoTo 0
    Next r1
    For Each item In c
        If CLng(item) <= .[c3] Then
            .Range("c" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        Else
            .Range("q" & .Rows.Count).End(xlUp) _
                .Offset(1, 0).Value = CLng(item)
        End If
    Next item
End With
End With
End Sub

ติดปัญหาที่ code ตรง Cdbl กำหนดให้รับค่าเป็นแบบ double แต่พอมาแสดงผลมันไม่แสดงค่ะ

[snasui]

Cdbl ใส่ไว้ผิดที่ แก้ไขให้กลับไปเหมือนเดิมครับ

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

Code: Select all

For Each item In c
    If CDbl(item) <= .[c3] Then
        .Range("c" & .Rows.Count).End(xlUp) _
            .Offset(1, 0).Value = CDbl(item)
    Else
        .Range("q" & .Rows.Count).End(xlUp) _
            .Offset(1, 0).Value = CDbl(item)
    End If
Next item

[chom_poona]

** ลองแก้ แล้ว จุดทศนิยม ออกแล้วค่ะ ขอบคุณค่ะ ขอเช็ค ความถูกต้องของข้อมูลก่อนค่ะ

[chom_poona]

อยากจะขอรบกวน อีกครั้งหนึ่งค่ะ

ค่าที่ได้ ออกมา มีค่า 0 ออกมาด้วยค่ะ ไม่ต้องการให้ค่า 0 ออกมาทำอย่างไรได้บ้างค่ะ

[snasui]

ปรับมาเองก่อน ติดแล้วค่อยถามกันครับ