เพิ่มเติม Code ย้ายข้อมูล

[predee16]

ผมต้องการย้ายข้อมูลจาก Sheet Dataไปที่ Sheet Cut of InterCo โดยมีเงื่อนไขดังนี้ครับ
- Column AC ที่มีคำว่า "Cut of InterCo" ให้ย้ายไปที่ Sheet "Cut of InterCo"
- และไม่ใช่ Column W ที่มีคำว่า "TT" กลุ่มนี้เอาไว้ที่ Sheet เดิม
ซึ่ง Code ที่มีอยู่ตอนนี้มันเอาคำว่า "Cut of InterCo" มาทั้งหมดครับ

Code: Select all

Sub test()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Data").UsedRange.Rows.Count
    J = Worksheets("Cut of InterCo").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Cut of InterCo").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Data").Range("aC2:aC" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Cut of InterCo" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Cut of InterCo").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Cut of InterCo" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
 Range("A2:AK20000").Sort Key1:=Range("A2"), _
                     Order1:=xlAscending, _
                     Header:=xlNo
End Sub

[niwat2811]

ลอง Code นี้ดูว่าได้ตรงตามต้องการไหมครับ

Code: Select all

Sub Test1()
Dim lr As Long, Rng As Range
lr = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("A1:AK" & lr).AutoFilter Field:=29, Criteria1:= _
        "Cut of InterCo"
    ActiveSheet.Range("A1:AK" & lr).AutoFilter Field:=23, Criteria1:="<>TT"
    ActiveSheet.Range("A2:AK" & lr).Copy Sheets("Cut of InterCo").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Set Rng = Range("A2:A" & lr).SpecialCells(xlCellTypeVisible)
    Rng.EntireRow.Delete
    ActiveSheet.ShowAllData
End Sub

[predee16]

niwat2811 ใช้งานได้ตามต้องการ ขอบคุณมากครับ