การคัลลอกตารางไปอีกเซลล์ ช่วยดูให้หน่อยครับ excel vba

[enjoygo]

การคัลลอกตารางไปอีกเซลล์ ช่วยดูให้หน่อยครับ
คือมีเงือนไขอยู่ว่า
1 ถ้า x = y ให้คัดลอกไปอีกชีทหนึ่ง ถ้าไม่ใช้ ให้ y หาซ้ำจนกว่าจะเจอ
ถ้าเจอแล้วให้ให้ตรวจบรรทัดทัดไปว่าเป็นเซลล์ว่างหรือไม่ ถ้าไม่ให้คัดลอก ถ้าว่างให้วน x ครับ
2 ให้ x วนไปจนครบตามหรัสที่ต้องการหา

ตอนนี้ผมติดปัญหาคือไม่รู้จะเอาเงือนไข 2 อันนี้มารวมกันยังไง หรือผิดทั้งหมดก็ไม่แน่ใจ
ผมขอคำปรึกษาด้วยครับ


รายละเอียดในไฟล์น่ะครับ
ชีท TTH1 จะเป็นข้อมูลที่ใช้หา
ชีท TTH2 จะเป็นข้อมูลที่จะหา
ชีท TTH3 จะเป็นที่วางข้อมูล

ปล.ผมไม่เก่งด้านนี้เลยครับ , ขอบคุณครับ

ไฟล์ตัวอย่างครับ
https://drive.google.com/open?id=0Bw2wW ... 3ZxaG8zWUE
https://drive.google.com/open?id=0Bw2wW ... U16bkk3VW8

code1

Code: Select all

Private Sub CommandButton2_Click()
Dim i As Integer
Dim j As Integer
Dim x As String
Dim y As String
Dim z As String
Dim p As String
Dim q As String
j = 2
i = 1
p = 1
q = 1

Do While j < 200
x = Sheets("TTH2").Cells(i, 1)
y = Sheets("TTH1").Cells(j, 2)
Select Case x
Case Is = y
Sheets("TTH1").Range(Cells(j, 1), Cells(j, 5)).Copy Sheets("TTH3").Cells(p, 1)
Do While p < 200
j = j + 1
p = p + 1
y = Sheets("TTH1").Cells(j, 2)
If y = "" Then
j = 200
Else
Sheets("TTH1").Range(Cells(j, 1), Cells(j, 5)).Copy Sheets("TTH3").Cells(p, 1)
q = q + 1
End If
Loop
Case Is <> y
j = j + 1
End Select
Loop
p = q + 1
End Sub

code2

Code: Select all

Private Sub CommandButton2_Click()
Dim i As Integer
Dim j As Integer
Dim x As String
Dim y As String
Dim p As String
Dim q As String
j = 2
i = 1

Do While i < 20
Do While j < 200
x = Sheets("TTH2").Cells(i, 1)
y = Sheets("TTH1").Cells(j, 2)

Select Case x
Case Is = y
Sheets("TTH1").Range(Cells(j, 1), Cells(j, 17)).Copy Sheets("TTH2").Cells(i, 2)
j = 200
Case Is <> y
Sheets("TTH2").Cells(i, 2) = "äÁ辺¢éÍÁÙÅ"
j = j + 1
End Select
Loop
i = i + 1
j = 2
Loop

End Sub

[snasui]

กรุณาแนบไฟล์มาที่ฟอรัมนี้แทนการแนบไว้ที่อื่น จะได้ไม่เกิดปัญหาในวันหลังหากไฟล์ต้นแหล่งถูกลบทิ้งไป เพราะที่ฟอรัมนี้ไม่มีการลบไฟล์แนบทิ้งครับ

[enjoygo]

แก้ไม่ได้ครับ ปุ่มแก้ไขไม่ขึ้นเลครับ

[snasui]

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

Code: Select all

Dim rall As Range, r As Range
Dim rtAll As Range, l As Long
Dim found As Long
With Sheets("TTH1")
    Set rall = .Range("b2", .Range("b" & .Rows.Count).End(xlUp))
    With .Parent.Sheets("TTH2")
        Set rtAll = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
    End With
    For Each r In rall
        If Application.CountIf(rtAll, r) > 0 Then
            found = Application.Match(r, rtAll, 0) - 1
            With .Parent.Sheets("TTH3")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value _
                    = r.Resize(1, 5).Value
            End With
        End If
    Next r
End With

[enjoygo]

ขอบพระคุณมากๆเลยครับ

ผมจะนำไปลองใช้ดูครับ

[enjoygo]

ช่วยแนะนำหนังสืออ่านเพิ่มเติมจะได้ไหมครับ

[enjoygo]

ผมแนบไฟล์ผิดมาครับ ผมต้องขอโทษด้วยครับ
ที่ผมยังติดปัญหาคือ
รหัส 888 จะมีพาร์ดลูก ผมต้องการให้โค๊ดมันก๊อปพาร์ดลูกมาด้วยพอเจอช่องว่างแล้วให้มันหยุดก๊อปแล้วรัน x ถัดไป
เพราะฉนั้นจะมี 2 กรณีคือ
กรณีที่ 1 คือไม่มีพาร์ดลูก
กรณีที่ 2 คือมีพาร์ดลูก

[snasui]

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