ต้องการได้ผลลัพธ์ที่ไวขึ้นโดยไม่ใช้ Loop หรือถ้าใช้ต้องปรับอย่างไรให้ได้ผลลัพธ์ที่ไวขึ้น

[10idlnw]

สมมติมีข้อมูลดิบดังนี้

Code: Select all

ผลคะแนน
3/12/2023

วิ่งผลัด
10|10

ชักเย่อ
5|10

กระโดดตบ
3|10

ดันพื้น
4|10

หกกบ
6|10
โหนบาร์
8|10

ซึ่งโค้ด vba ที่ผลใช้คือ

Code: Select all

Sub CopyCDataToNextColumn()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim data As Variant
    data = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1)).value
    
    Dim i As Long
    For i = 1 To UBound(data, 1)
        If InStr(1, data(i, 1), "|", vbTextCompare) > 0 Then
            Dim value As String
            value = Replace(data(i, 1), "|", "-")
            ws.Cells(i - 1, 2).value = value
            ws.Cells(i, 1).value = ""
        End If
    Next i
    
        Dim j As Long
    j = 1 ' Start from the first row
    
    Do While j <= lastRow
        If ws.Cells(j, 1).value = "" Then
            ' If an empty cell is found, delete the entire row
            ws.Rows(j).Delete
            lastRow = lastRow - 1 ' Update the lastRow
        Else
            j = j + 1 ' Move to the next row
        End If
    Loop
    
    Dim k As Long
    k = 1 ' Start from the first row
    
    Do While k <= lastRow
        If InStr(1, ws.Cells(k, 1).value, "ผลคะแนน", vbTextCompare) > 0 Or IsDate(ws.Cells(k, 1).value) Then
            ' If "ผลคะแนน" is found in the cell, delete the entire row
            ws.Rows(k).Delete
            lastRow = lastRow - 1 ' Update the lastRow
        Else
            k = k + 1 ' Move to the next row
        End If
    Loop

    
End Sub

มันทำงานได้ถูกต้องตามต้องการทุกประการ แต่ถ้ามีชุดข้อมูลหลายๆแถว เช่น 100 แถวมันทำงานได้ช้ามาก เพราะมันทำทีละคำสั่ง ทีละบรรทัด ผลต้องปรับโค้ด หรือใช้โค้ดใดใน VBA เพื่อให้ได้ผลลัพธ์แบบเดียวกันแต่ใช้เวลาประมวลผลที่ไว และรวดเร็ว ต้องปรับเปลี่ยนแก้โค้ดอย่างไรครับ

Capture.JPG

Capture2.JPG

[snasui]

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

Code: Select all

Sub CopyCDataToNextColumn()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim value As String
    Dim data As Variant
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        data = .Range(.Cells(1, 1), .Cells(lastRow, 1)).value
        For i = UBound(data, 1) To 1 Step -1
            If InStr(1, data(i, 1), "|", vbTextCompare) > 0 Then
                value = Replace(data(i, 1), "|", "-")
                .Cells(i - 1, 2).value = value
                .Cells(i, 1).value = ""
            End If
        Next i
        Set data = .Range("a1", .Range("a" & .Rows.Count).End(xlUp)) _
            .SpecialCells(xlCellTypeBlanks)
        data.EntireRow.Delete
        .Range("a1:a2").EntireRow.Delete
    End With
    
'    Dim j As Long
'    j = 1 ' Start from the first row
'
'    Do While j <= lastRow
'        If ws.Cells(j, 1).value = "" Then
'            ' If an empty cell is found, delete the entire row
'            ws.Rows(j).Delete
'            lastRow = lastRow - 1 ' Update the lastRow
'        Else
'            j = j + 1 ' Move to the next row
'        End If
'    Loop
'
'    Dim k As Long
'    k = 1 ' Start from the first row
'
'    Do While k <= lastRow
'        If InStr(1, ws.Cells(k, 1).value, "¼Å¤Ðá¹¹", vbTextCompare) > 0 Or IsDate(ws.Cells(k, 1).value) Then
'            ' If "¼Å¤Ðá¹¹" is found in the cell, delete the entire row
'            ws.Rows(k).Delete
'            lastRow = lastRow - 1 ' Update the lastRow
'        Else
'            k = k + 1 ' Move to the next row
'        End If
'    Loop
End Sub

[10idlnw]

ขอบคุณมากครับอาจารย์ ใช้งานได้ตามความต้องการครับ