VBA ต้องการให้ Copy ตามเงื่อนไขค่ะ

[suka]

เรียนอาจารย์และท่านผู้ช่วยค่ะ

ขอรบกวนช่วยปรับโค้ดจากตัวอย่างไฟล์ที่ชีท Form ใส่วันที่เริ่ม - ถึงวันที่ และรหัส หากตรงกับชีท Database คอลัมน์ M ไม่ว่างและรหัสที่คอลัมน์ F ตรงกันให้ Copy ข้อมูลที่ตรงกันมาไว้ที่ชีท Unbillede ค่ะ Code ด้านล่างฟ้องตามรูปแนบค่ะ

ตัวอย่างที่ต้องการที่ชีท Unbillede ค่ะ ขอบคุณค่ะ

Code: Select all

Sub Unbillede()
       Dim icount As Integer
       Dim sh2Range As Range
       icount = Worksheets("Database").Range("M100000").End(xlUp).Row
        Do
            If Worksheets("Database").Cells(icount, "M") <> 0 Then
                Worksheets("Database").Cells(icount, "M").EntireRow.Copy
                Worksheets("Unbillede").Cells(65536, "F").End(xlUp) _
                    .Offset(1, 0).PasteSpecial xlPasteValues
                Worksheets("Database").Cells(icount, "M").EntireRow.Delete
            End If
        icount = icount - 1
        Loop Until icount = 1
        With Worksheets("Unbillede")
        Set sh2Range = .Range("F1", .Range("M" & Rows.Count).End(xlUp))
       End With
End Sub

[snasui]

จาก Code นี้

Code: Select all

Worksheets("Database").Cells(icount, "M").EntireRow.Copy
Worksheets("Unbillede").Cells(65536, "F").End(xlUp) _
      .Offset(1, 0).PasteSpecial xlPasteValues

เป็นการ Copy ทั้งบรรทัดไปวาง ซึ่งการวางตาม Code นั้นจะวาง "ทั้งบรรทัด"

การ Copy และวาง โดยทั่วไปควรจะกำหนดพื้นที่ให้เท่ากัน หากพื้นที่ที่ Copy มีขนาดเกินกว่าพื้นที่ที่ต้องการจะวาง จะเป็นปัญหาตามภาพที่จับมาครับ

[suka]

อาจารย์คะ ต้องการให้โค้ดด้านล่างนี้ Copy เฉพาะเซลล์ที่ตรงกับค่าที่ใส่ในเซลล์ B5:D5 ของชีท Form ไปวางที่ชีท Unbillede โค้ดควรปรับอย่างไรคะ

Code: Select all

Sub Unbillede()
       Dim icount As Integer
       Dim sh2Range As Range
       icount = Worksheets("Database").Range("M50000").End(xlUp).Row
        Do
            If Worksheets("Database").Cells(icount, "M") <> 0 Then
                Worksheets("Database").Cells(icount, "M").EntireRow.Copy
                Worksheets("Unbillede").Cells(50000, "a").End(xlUp) _
                    .Offset(1, 0).PasteSpecial xlPasteValues
                Worksheets("Database").Cells(icount, "M").EntireRow.Delete
            End If
        icount = icount - 1
        Loop Until icount = 1
        With Worksheets("Unbillede")
        Set sh2Range = .Range("a1", .Range("M" & Rows.Count).End(xlUp))
       End With
End Sub

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Dim rall As Range, r As Range
With Sheets("Database")
    Set rall = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
    For Each r In rall
        If r.Value2 >= Sheets("form").Range("b5").Value2 And _
            r.Value2 <= Sheets("form").Range("c5").Value2 And _
            r.Offset(0, 5).Value = Sheets("form").Range("d5").Value Then
            With Sheets("Unbillede")
                With .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
                    .Resize(1, 13).Value = r.Resize(1, 13).Value
                End With
            End With
        End If
    Next r
End With

[suka]

ขอบคุณอาจารย์มาก ๆ เลยค่ะ ปรับโค้ดให้ใช้งานได้ง่ายและไวมากค่ะ