เอาผลจากคอลัมน์มาเขียนคำสั่ง VBA ให้สร้างอีก 1 คอลัมน์

[snasui]

ลบวงเล็บก่อนเครื่องหมาย <> ออกไป 1 ตัวครับ

[aroydee]

มันฟ้องแบบนี้ครับ

[snasui]

แก้เป็นแบบนี้ครับ

If UCase(VBA.Left(Range("f" & Rows.Count).End(xlUp).Offset(0, 6).Value, 1)) <> "T" Then

[aroydee]

ได้ละครับ
ขอบคุณครับอาจารย์

[aroydee]

ที่ผ่านมา Code ทำงานได้ปกติครับ แต่ปัญหาต่อมา คือ
สูตรที่ผมใช้ในการดึงค่าไปสร้างตาราง
LOOKUP(2,1/(AN3:AN79<>""),AN3:AN79) ดึงตัวสุดท้ายก่อนค่าว่างไปแสดง
พอเกิด Action ในตาใหม่ มันก็เลยดึงค่าที่อยู่ก่อนหน้ามาแสดงซ้ำอีกรอบครับ

[snasui]

แนบไฟล์ล่าสุดมาด้วยจะได้สะดวกในการตอบครับ

[aroydee]

อันเก่าโอเคละครับ
แต่เหมือนจะหลายขั้นตอน ดูยุ่งยากครับ

[aroydee]

เลยอยากแก้ไขใหม่ครับ
1.การป้อนสกอร์ ไม่ต้องใช้ตัวเลขแยกสี ใช้ชุดเดียวเลยครับ
2.โดยป้อนให้ตัวเลขเรียงต่อกันในสี่เหลี่ยมสีน้ำเงิน - แดง (ด้านบน ขวามือ) ไปทีละตัวจากซ้ามือครับ
3.แล้วค่อยกดแป้น "บันทึกแต้ม" ตัวเลขจึงถูกคัดลอกไปอยู่ใน C19:H19 ....
โดยชุดนี้ใช้ Module4 เขียน VBA ครับ

[aroydee]

ส่วนนี้ครับ

[aroydee]

ลำดับต่อมาครับ

[aroydee]

VBA ใน Module4 ครับ

Code: Select all

Sub Card0()
Application.ScreenUpdating = False
    With Sheets("Trics")
    If .Range("Pla" & Rows.Count).End(xlUp).Row = 10 Then Exit Sub
    [TargetPla] = 0
    [TargetBnk] = 0
    End With
Application.ScreenUpdating = True
End Sub
Sub Card1()
    Application.ScreenUpdating = False
    [TargetPla] = 1
    [TargetBnk] = 1
    Application.ScreenUpdating = True
End Sub
Sub Card2()
    Application.ScreenUpdating = False
    [TargetPla] = 2
    [TargetBnk] = 2
    Application.ScreenUpdating = True
End Sub
Sub Card3()
    Application.ScreenUpdating = False
    [TargetPla] = 3
    [TargetBnk] = 3
    Application.ScreenUpdating = True
End Sub
Sub Card4()
    Application.ScreenUpdating = False
    [TargetPla] = 4
    [TargetBnk] = 4
    Application.ScreenUpdating = True
End Sub
Sub Card5()
    Application.ScreenUpdating = False
    [TargetPla] = 5
    [TargetBnk] = 5
    Application.ScreenUpdating = True
End Sub
Sub Card6()
    Application.ScreenUpdating = False
    [TargetPla] = 6
    [TargetBnk] = 6
    Application.ScreenUpdating = True
End Sub
Sub Card7()
    Application.ScreenUpdating = False
    [TargetPla] = 7
    [TargetBnk] = 7
    Application.ScreenUpdating = True
End Sub
Sub Card8()
    Application.ScreenUpdating = False
    [TargetPla] = 8
    [TargetBnk] = 8
    Application.ScreenUpdating = True
End Sub
Sub Card9()
    Application.ScreenUpdating = False
    [TargetPla] = 9
    [TargetBnk] = 9
    Application.ScreenUpdating = True
End Sub
Sub NoCard()
    Application.ScreenUpdating = False
    [TargetPla] = "-"
    [TargetBnk] = "-"
    Application.ScreenUpdating = True
End Sub
Sub Back()
Application.ScreenUpdating = False
    [TargetUPla] = ""
    [TargetUBnk] = ""
Application.ScreenUpdating = True
End Sub
Sub Reset()
Application.ScreenUpdating = False
    Range("Pla").ClearContents
    Range("Bnk").ClearContents
Application.ScreenUpdating = True
End Sub
Sub NewGame()
Application.ScreenUpdating = False
    Range("Pla").ClearContents
    Range("Bnk").ClearContents
    Range("PCard").ClearContents
    Range("BCard").ClearContents
Application.ScreenUpdating = True
End Sub
Sub AddScore()
Application.ScreenUpdating = False
    With Sheets("Trics")
        Range("D3:D5").Copy
        Range("C" & Rows.Count).End(xlUp).Offset(1, 0) _
            .PasteSpecial xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=True
        Range("G3:G5").Copy
        Range("F" & Rows.Count).End(xlUp).Offset(1, 0) _
            .PasteSpecial xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=True
'Other code                            ... คัดลอก [K] ไป [AN]
'        Range("an" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
'            Range("f" & Rows.Count).End(xlUp).Offset(0, 6).Value
'Other code                            ... ไม่คัดลอกตัวเสมอ
If UCase(VBA.Left(Range("f" & Rows.Count).End(xlUp).Offset(0, 6).Value, 1)) <> "T" Then
    Range("an" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
            Range("f" & Rows.Count).End(xlUp).Offset(0, 6).Value
End If
'Other code
        Range("PS").ClearContents
        Range("BS").ClearContents
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Sub UndoScore()
Application.ScreenUpdating = False
    With Sheets("Trics")
    If .Range("C" & Rows.Count).End(xlUp).Row = 18 Then Exit Sub
    .Range("C" & Rows.Count).End(xlUp).Resize(1, 6).ClearContents
    End With
Application.ScreenUpdating = True
End Sub

[snasui]

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

[aroydee]

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

[snasui]

ติดตรงไหนกรุณาระบุมาด้วย ผมอ่านแล้วไม่พบว่าเป็นการถามสิ่งที่เป็นปัญหาครับ

ควรถามให้ผ่านไปทีละประเด็นครับ

[aroydee]

ใส่ได้ตัวแรกตัวเดียวครับ ตัว 2-6 ไม่รู้จะไปยังไง

Code: Select all

Sub Card0()
Application.ScreenUpdating = False
    With Sheets("Trics")
    'If .Range("Pla" & Rows.Count).End(xlUp).Row = 10 Then Exit Sub
    Dim i As Integer
    Dim sel As Range
    Set sel = [AQ2,AU2,AY2,BC2,BG2,BK2]
    For i = 1 To 6
        If i = 1 Then sel.Columns(i) = 0
        
        Next i

    End With
'Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[aroydee]

แบบนี้ครับ

[snasui]

ผมลองคีย์ตัวเลขในช่องสีน้ำเงินและสีแดงครบทุกช่องแล้วคลิกปุ่ม บันทึกแต้ม พบว่าไม่มีการ Assign Macro ให้กับปุ่มนี้

ไม่ทราบว่าได้เขียน Code เกี่ยวกับการบันทึกแต้มแล้วหรือไม่ เขียนไว้อย่างไร อยู่ที่ Module ไหน ติดขัดบรรทัดใดครับ

[aroydee]

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

[aroydee]

แต่จะมาใช้ชุดนี้แทนครับ
1.ใช้เลขชุดเดียว (แป้นสีส้ม 0-9) คีย์ให้แสดงเรียงลำดับในช่อง น้ำเงิน-แดง 6 ช่องด้านบน
2.Code ที่เขียนอยู่ใน Module4 หัวข้อ Sub Card0() ครับ
เพิ่ง Assign macro แค่ตัวเลข 0 มันก็ไม่ไปเรียงลำดับซะแล้ว มันค้างอยู่แค่ช่องน้ำเงินช่องแรกช่องเดียวเองครับ

[aroydee]

ไฟล์ กับ Code ล่าสุดครับ
คีย์เลขใหม่ (ลองเลข 0 แค่ตัวเดียว) มันแสดงใน Card น้ำเงินซ้ำแค่ช่องแรกช่องเดียว
ไม่ยอมไปช่อง 2...6 ครับ

Code: Select all

Sub Card0()
Application.ScreenUpdating = False
    With Sheets("Trics")
    Range("AA2") = 0
    Dim i As Integer
    Dim sel As Range
    Set sel = [B2,E2,H2,K2,N2,Q2]
        If UCase(VBA.Left(Range("AA2").Value, 1)) <> "" Then
        For i = 1 To 6
            If i = 1 Then sel.Columns(i).Value = [AA2]
            Next i
            End If
        Range("AA2").ClearContents
    End With
Application.ScreenUpdating = True
End Sub