delete row

[Bafnet]

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

Code: Select all

Dim fileToOpen
Dim rs As Range
Dim Mydata As Range
Dim MyFile As String
Dim sFile As String
Dim xFile As String
Dim r As Long
Dim FileSaveName As String
'On Error Resume Next
Sheet3.Range("BG1").Value = 0
frmload.Label2.Font = "Wingdings 2"
frmload.Label2.Caption = "X"
frmload.Label2.ForeColor = &H80000005
Sheet3.Range("A:AZ").ClearContents
Application.ScreenUpdating = False
With Workbooks("CIM.xlsm").Worksheets("Cimy")
Set rs = Workbooks("CIM.xlsm").Worksheets("Cimy").Range("A1")
Set Mydata = Workbooks("CIM.xlsm").Worksheets("Cimy").Range("A:AT")
End With
fileToOpen = Application.GetOpenFilename '( _
      FileFilter:="WorkbookMacro(
       '(*.xls),*xls,(*xlsx),*xlsx")
      MyFile = fileToOpen
 If fileToOpen = False Then
  MsgBox "โปรดเลือกไฟล์", vbOKOnly, "CIM 360"
 Exit Sub
 End If
   If fileToOpen <> False Then
 Workbooks.OpenText Filename:=MyFile
  Application.DisplayAlerts = False
   ActiveWorkbook.Worksheets(1).Columns("A:AT").Select
  Selection.Copy: rs.PasteSpecial xlPasteValues
   Application.CutCopyMode = False
 ActiveWorkbook.Close True
End If
Sheet3.Activate
Rows("1:1").Select
    Selection.Delete Shift:=xlUp
  Columns("Q:R").Select
    Selection.Delete Shift:=xlToLeft
Sheet3.Activate
Columns("R:T").Select
    Selection.Delete Shift:=xlToLeft
 Sheet1.Activate
   With Workbooks("CIM.xlsm").Worksheets("Cimy")
 r = 2
Do Until Sheet3.Cells(r, 2).Value = ""
 Sheet3.Cells(r, 42).Formula = "=VLOOKUP(" & Sheet3.Cells(r, 2).Address & ",Cimx!B:B,1,0)"
 Sheet3.Cells(r, 43).Formula = "=IFERROR(" & Sheet3.Cells(r, 42).Address & ",""X"" )"
  Sheet3.Cells(r, 1).Value = Sheet3.Cells(r, 43).Value
 r = r + 1
frmload.TextBox1.Value = r - 1
     DoEvents
Loop
    End With
    
 With Workbooks("CIM.xlsm").Worksheets("Cimy")
 r = 2
Do Until Sheet3.Cells(r, 1).Value = ""
  If Sheet3.Cells(r, 1).Value = "X" Then
           Sheet3.Cells(r, 1).EntireRow.Delete
       End If
 r = r + 1
frmload.TextBox1.Value = r - 1
     DoEvents
Loop
     
  End With

ช่วยแนะนำหน่อยนะครับ ผมเอา
If Sheet3.Cells(r, 1).Value = "X" Then
Sheet3.Cells(r, 1).EntireRow.Delete
End If
ไปรวมกับคำสั่ง VLOOKUP แล้ว
With Workbooks("CIM.xlsm").Worksheets("Cimy")
r = 2
Do Until Sheet3.Cells(r, 2).Value = ""
Sheet3.Cells(r, 42).Formula = "=VLOOKUP(" & Sheet3.Cells(r, 2).Address & ",Cimx!B:B,1,0)"
Sheet3.Cells(r, 43).Formula = "=IFERROR(" & Sheet3.Cells(r, 42).Address & ",""X"" )"
Sheet3.Cells(r, 1).Value = Sheet3.Cells(r, 43).Value
If Sheet3.Cells(r, 1).Value = "X" Then
Sheet3.Cells(r, 1).EntireRow.Delete
End If
r = r + 1
frmload.TextBox1.Value = r - 1
DoEvents
Loop
End With

ผลที่ได้กลับไม่ลบแถวที่ต้องการ ขอบคุณครับ

[snasui]

ลองดูตัวอย่าง Code สำหรับการลบบรรทัดตามด้านล่างครับ

เป็นการตรวจสอบว่าหาก Sheet3.Cells(r, 1).Value = "X" แล้ว ให้ เป็นเซลล์ว่าง จากนั้นค่อยเลือกเซลล์ว่างทั้งหมดแล้วลบพร้อมกันทีเดียว

Code: Select all

'Other code
r = 2
Do Until Sheet3.Cells(r, 1).Value = ""
     If Sheet3.Cells(r, 1).Value = "X" Then
              Sheet3.Cells(r, 1) = ""
          End If
    r = r + 1
    frmload.TextBox1.Value = r - 1
    DoEvents
Loop
With Sheet3
    .Range("a2", .Range("a" & Rows.Count).End(xlUp)) _
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
'Other code

[Bafnet]

สวัสดีครับ ได้ลองแก้ไขแล้วครับ
พร้อมกับได้ลองใช้อีกวิธีคือกรองfillter=x แล้วลบแถวทิ้งครับ
ขอบคุณมากครับ
ขออนุญาติถามปัญหาต่อนะครับ
พยายามลองแล้วครับแต่เขียนสูตรบน Vb ไม่ถูกครับ
สูตรที่ต้องการคือ
โดยมีข้อมูลที่ T2 = 20/12 ม.4 ต.ตะโละดือรามัน
1.ที่AI2=SEARCH("ม.",T2) หาตำแหน่ง
2.ที่AJ2=IFERROR(MID(T2,1,AI2-1),T2) ได้เลขที่บ้าน
3.ที่AK2=IFERROR(MID(T2,AI2+2,2),U2) ได้หมู่ที่

ผมเขียน code ใน vb ไม่ถูกครับ

With Workbooks("CIM.xlsm").Worksheets("Cimx")
r = 2
Do Until Sheet2.Cells(r, 2).Value = ""
Sheet2.Cells(r, 35).Formula = "=SEARCH(""ม.""," & Sheet2.Cells(r, 20).Address & ")"
Sheet2.Cells(r, 36).Formula = "=IFERROR(MID(" & Sheet2.Cells(r, 20).Address & ",1," & Sheet2.Cells(r, 35).Address & "-1," & Sheet2.Cells(r, 20).Address & ")"
Sheet2.Cells(r, 37).Formula = "=IFERROR(MID(" & Sheet2.Cells(r, 20).Address & "," & Sheet2.Cells(r, 35).Address & "+2,2," & Sheet2.Cells(r, 21).Address & ")"
r = r + 1
frmload.TextBox1.Value = r - 1
DoEvents
Loop
End With

ไม่กล้ารันคำสั่ง กลัวครับ งงๆเพราะในสูตรMID มันมีทั้ง - +
เลยขอให้อาจารย์ดูให้ก่อนครับ ว่าจะได้ค่าตามสูตรที่เราต้องการหรือเปล่า

[Bafnet]

ลองรันแล้วครับ ผิดครับ
=IFERROR(MID(T2,1,AI2-1),T2) เขียนเป็น
Sheet2.Cells(r, 36).Formula = "=IFERROR(MID(" & Sheet2.Cells(r, 20).Address & ",1," & Sheet2.Cells(r, 35).Address & "-1," & Sheet2.Cells(r, 20).Address & ")"
=IFERROR(MID(T2,AI2+2,2),U2) เขียนเป็น
Sheet2.Cells(r, 37).Formula = "=IFERROR(MID(" & Sheet2.Cells(r, 20).Address & "," & Sheet2.Cells(r, 35).Address & "+2,2," & Sheet2.Cells(r, 21).Address & ")"
ผิดครับ น่าจะใส่ฟันหนู หรือ & หรือ ให้ค่าบวกลบที่ผิด
รบกวนด้วยนะครับ

[snasui]

.Address คือตำแหน่งเซลล์ แต่สิ่งที่ต้องการคือนำ Value มาใช้ ดังนั้น ให้เปลี่ยน .Address เป็น .Value ครับ

[Bafnet]

ได้แล้วครับอาจารย์
ผมใส่วงเล็บและฟันหนูไม่ครบครับ
"=IFERROR(MID(" & Sheet2.Cells(r, 20).Address & ",1," & Sheet2.Cells(r, 35).Address & "-1," & Sheet2.Cells(r, 20).Address & ")"
ที่ถูกต้องเป็น
"=IFERROR(MID(" & Sheet2.Cells(r, 20).Address & ",""1""," & Sheet2.Cells(r, 35).Address & "-""1"")," & Sheet2.Cells(r, 20).Address & ")"
.value ก็ได้ทดลองเปลี่ยนดูแล้วครับ
ขอบคุณมากๆครับ

[snasui]

ผมก็ลืมนึกไปว่าใช้สูตรเข้ามาช่วยซึ่งสามารถใช้ได้ทั้ง 2 อย่างครับ