ขอรบกวนช่วยเรื่อง Code VBA เมื่อเทียบค่าตรงกัน

[suka]

เรียนท่านผู้รู้ช่วยเหลือเรื่องช่วยปรับ Code ตามตัวอย่างด้างล่างนี้ค่ะ
ต้องการให้โปรแกรมเทียบค่าตัวเลขเอกสารเมื่อมีการบันทึกที่ชีท Form เซลล์ B3:B47
หากเลขที่ตรงกันกับชีท Database คอลัมน์ D ให้โปรแกรมใส่ Y ที่คอลัมน์ AC ค่ะ
Code นี้อยู่ที่ Module1 ชื่อ BeenArL ค่ะ ขอบคุณค่ะ

Code: Select all

Sub BeenArL()                            [attachment=0]Inventory.AR.xls[/attachment]
    Application.ScreenUpdating = False
    Sheets("TemBilling").Range("A12:O12").Copy
    Sheets("AR").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("TemBilling").Range("P12:W12").Copy
    Sheets("Report").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("Form").Range("H1,J2,I4:L4,L6,G4").ClearContents
    With Sheets("Form")
            .Range("J6") = .Range("J6") + 1
        End With
        Application.ScreenUpdating = True
End Sub

[snasui]

Code ที่เขียนมาไม่มี Code สำหรับการเปรียบเที่ยบอยู่ด้วย ลองเขียนมาก่อนติดตรงไหนแล้วค่อยถามกันครับ

[suka]

ค่ะอาจารย์ ได้ลองเองแล้วไม่สำเร็จค่ะ Code ตามนี้ไม่ได้ค่ะ

Code: Select all

Sub BeenArL()                           
Dim lng As Long
Dim r As Range
Dim i As Integer
Set r = Sheets("Form").Range("B3:B47")
With Sheets("Database")
    i = Application.Match(r, .Range("D:D"), 0)
        Exit Sub
    End If
End With
    Application.ScreenUpdating = False
    Sheets("TemBilling").Range("A12:O12").Copy
    Sheets("AR").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("TemBilling").Range("P12:W12").Copy
    Sheets("Report").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("Form").Range("H1,J2,I4:L4,L6,G4").ClearContents
    With Sheets("Form")
            .Range("J6") = .Range("J6") + 1
        End With
        Application.ScreenUpdating = True
Sheets("Database").Range("AC" & i) = "Y"
End Sub

[snasui]

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

Code: Select all

    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    With Sheets("Form")
        Set rSource = .Range("B3", .Range("B47").End(xlUp))
    End With
    With Sheets("Database")
        Set rTarget = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
    End With
    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 26) = "Y"
        Next rt
    Next rs
'Other code

[suka]

ขอบพระคุณมากๆค่ะอาจารย์ ได้ตรงตามการเลยค่ะ

[suka]

อาจารย์คะ ขอรบกวนเรื่องปรับ Code เพิ่มอีกหนึ่งเงื่อนไขค่ะ
ตัวอย่างไฟล์แนบที่ชีท Database เซลล์ D3:D7 เลขที่เอกสารเดียวกันมี 5 รายการ แต่ Code ไฟล์แนบใส่ Y ที่เซลล์ AC3 แค่ตัวเดียวค่ะ
ต้องการให้ Code ตรวจสอบที่คอลัมน์ E ชีท Database และใส่ Y ที่คอลัมน์ AC ตามจำนวนเลขที่รันในคอลัมน์ E ชีท Database ด้วยค่ะ เมื่อกดปุ่ม Record ที่ชีท Form ค่ะ

ชือ BeenArL อยู่ที่ Module1 ค่ะ

ขอบคุณค่ะ

[snasui]

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

Code: Select all

'Other code
    Application.Calculation = xlCalculationManual
    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 25) = "Y"
        Next rt
    Next rs
    Application.Calculation = xlCalculationAutomatic
'Other code

[suka]

ขอบคุณอาจารย์ค่ะ ใช้ได้ตรงตามต้องการแล้วค่ะ

[suka]

อาจารย์คะ ขอรบกวนเรื่องปรับ Code อีกรอบค่ะ
เมื่อกดปุ่ม Record ชีท Form เซลล์ B3:B47 เรียกเอกสารมากกว่าหนึ่ง ให้ Code ใส่ Y ที่ชีท Database คอลัมน์ AC ตามจำนวนเอกสารที่เรียกทุกรายการที่เลขเอกสารตรงกับคอลัมน์ D ชีท Database ค่ะ Code ด้านล่างนี้ใส่ให้แค่หนึ่งเอกสารที่ตรงกันเท่านั้นค่ะ

ชือ BeenArL อยู่ที่ Module1 ค่ะ

ขอบคุณค่ะ

Code: Select all

Sub BeenArL()                                  
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    With Sheets("Form")
        Set rSource = .Range("B3", .Range("B47").End(xlUp))
    End With
    With Sheets("Database")
        Set rTarget = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
    End With
    Application.Calculation = xlCalculationManual
    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 25) = "Y"
        Next rt
    Next rs
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
    Sheets("TemBilling").Range("A12:O12").Copy
    Sheets("AR").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("TemBilling").Range("P12:W12").Copy
    Sheets("Report").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("Form").Range("H1,J2,I4:L4,L6,G4").ClearContents
    With Sheets("Form")
            .Range("J6") = .Range("J6") + 1
        End With
        Application.ScreenUpdating = True
End Sub

[snasui]

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

Code: Select all

'Other code
    With Sheets("Form")
        Set rSource = .Range("B3:B47")
    End With
'Other code

[suka]

ขอบคุณอาจารย์ค่ะ ใช้ได้แล้วได้ตรงตามต้องการค่ะ

[suka]

อาจารย์คะ ขอรบกวนเรื่อง Code ให้ตรวจสอบหากชีท Form เซลล์ L4+L6 บวกกันแล้วยอดไม่ตรงกับยอดในเซลล์ J8 ชีท Form จะไม่สามารถกดปุ่ม Record ได้ค่ะ

ชือ BeenArL อยู่ที่ Module1 ค่ะ

ขอบคุณค่ะ

[snasui]

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

[suka]

อาจารย์คะ ช่วยปรับ Code ด้านล่างนี้ให้หน่อยนะคะ

Code: Select all

With ActiveSheet
     i = (.Range("L4") + .Range("L6")) 
    If i <> ("J8") Then
        MsgBox "โปรดตรวจจำนวนเงินและบันทึกใหม่"
        Exit Sub
    End If

อาจารย์คะ ขอรบกวนเรื่อง Code ให้ตรวจสอบหากชีท Form เซลล์ L4+L6 บวกกันแล้วยอดไม่ตรงกับยอดในเซลล์ J8 ชีท Form จะไม่สามารถกดปุ่ม Record ได้ค่ะ

ชือ BeenArL อยู่ที่ Module1 ค่ะ

ขอบคุณค่ะ

เพื่อนำมาใช้ต่อจาก Code ไฟล์แนบนี้ค่ะ

ขอบคุณค่ะ

[snasui]

จาก Code If i <> ("J8") ควรเขียนเป็น if i <> .range("J8") ครับ

[suka]

อาจารย์คะ ได้แก้ code แล้วก็ยัง error ตามภาพค่ะ

[snasui]

มีคำว่าthen ตามหลังแล้วยังครับ

Code ต้องอยู่ในรูป if i <> .range("J8") then ถ้ามี if จะต้องมี then ตลอดกาลห้ามลืมครับ

โดยปกติหากไม่ไปกำหนดเป็นอย่างอื่น หาก Code ใดเป็นสีแดง ต้องแก้ไม่ให้เป็นสีแดงเสมอเช่นกัน ไม่เช่นนั้น Run ไม่ได้ครับ

[suka]

อาจารย์คะ ใส่ then ตามหลังแล้วก็ยัง error ตามภาพค่ะ

[snasui]

แสดงว่าบรรทัดบนสุดมีคำว่า Option Explicit ซึ่งจะต้องประกาศตัวแปรเสมอ ตัวแปร i ยังไม่ได้ประกาศตัวแปร ต้องประกาศด้วยครับ

[suka]

อาจารย์คะ Code ด้านล่างนี้ พอกดปุ่ม Record ก็ error แล้วมีแถบสีเหลืองที่บรรทัดบนสุด
Sub BeenArL() ' ปุ่มบันทึกรับชำระ ชีท Form
และมีแถบสีน้ำเงินที่ End Sub บรรทัดสุดด้วยค่ะ

Code: Select all

Sub BeenArL()                               ' ปุ่มบันทึกรับชำระ ชีท Form
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    Dim i As Integer
    With Sheets("Form")
        Set rSource = .Range("B3:B47")
    End With
    With Sheets("Database")
        Set rTarget = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
    End With
    Application.Calculation = xlCalculationManual
    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 25) = "Y"
        Next rt
    Next rs
    Application.Calculation = xlCalculationAutomatic
    With ActiveSheet
     i = (.Range("L4") + .Range("L6"))
    If i <> .Range("J8") Then
        MsgBox "โปรดตรวจจำนวนเงินและบันทึกใหม่"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Sheets("TemBilling").Range("A12:O12").Copy
    Sheets("AR").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("TemBilling").Range("P12:W12").Copy
    Sheets("Report").Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
    Sheets("Form").Range("H1,J2,I4:L4,L6,G4").ClearContents
    With Sheets("Form")
            .Range("J6") = .Range("J6") + 1
        End With
        Application.ScreenUpdating = True
End Sub