การเพิ่มความเร็วในการอัพเดทข้อมูล (VBA)

[bank9597]

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

ตามไฟล์แนบนั้น ไม่มีปัญหาติดขัดอะไรครับ ผมสามารถอัพเดทข้อมูลได้ถูกต้อง เพียงแต่จะสมมุติเหตุการณืว่าหากมีข้อมูลจำนวนเยอะประมาณ 1000 บรรทัดขึ้นไป จะปรับโคีดอย่างไรให้มันทำการอัพเดทเร็วกว่าเดิมครับ เบื้องต้นทดลองในไฟล์จริง ใช้เวลาไปต่อชีทเกือบ 30 วินาที ข้อมูลก็ไม่เยอะเท่าไหร่ครับ

ในไฟล์แนบ นำข้อมูลในชีม product ไปอัพเดทในชีท database และ Data พร้อมกัน โดยการสั่งงานเพียงครั้งเดียว
ผมใช้โค๊ดนี้ครับ

Code: Select all

Sub UpdateProduct()
Dim rsAll As Range, rtAll As Range
Dim rs As Range, i As Integer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error Resume Next
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Database")
    Set rtAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rs In rsAll
    For i = rtAll.Count To 1 Step -1
        If rs = rtAll(i) And rs.Offset(0, 0) = rtAll(i).Offset(0, 0) _
        And rs.Offset(0, 1) <> "" Then
            rs.Offset(0, 1).Copy
            rtAll(i).Offset(0, 1).PasteSpecial xlPasteValues
        End If
        Next i
    Next rs
    
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Data")
    Set rtAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rs In rsAll
    For i = rtAll.Count To 1 Step -1
        If rs = rtAll(i) And rs.Offset(0, 0) = rtAll(i).Offset(0, 0) _
        And rs.Offset(0, 1) <> "" Then
            rs.Offset(0, 1).Copy
            rtAll(i).Offset(0, 1).PasteSpecial xlPasteValues
        End If
        Next i
    Next rs
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("บันทึกข้อมูลเรียบร้อยแล้ว")

End Sub

รบกวนด้วยครับ

[snasui]

ลองปรับมาใช้ For each...Next ตามด้านล่างดูครับ

Code: Select all

Sub UpdateProduct()
    Dim rsAll As Range, rtAll As Range
    Dim rs As Range, rt As Range
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
'    On Error Resume Next
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Database")
    Set rtAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rs In rsAll
        For Each rt In rtAll
            If rs = rt Then
                rt.Offset(0, 1) = rs.Offset(0, 1)
            End If
        Next
    Next rs
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Data")
    Set rtAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rs In rsAll
        For Each rt In rtAll
            If rs = rt Then
                rt.Offset(0, 1) = rs.Offset(0, 1)
            End If
        Next rt
    Next rs
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox ("บันทึกข้อมูลเรียบร้อยแล้ว")
End Sub

[bank9597]

ขอบคุณอาจารย์มากๆครับ แล้วผมจะนำไปทดสอบกับไฟล์จริงแล้วมารายงานผลครับ ตอนนี้กลับห้องแล้ว เลยทดสอบกับไฟล์จริงไม่ได้

[tupthai]

Code: Select all

Sub Macro1()
    Application.ScreenUpdating = False
    
    '*****Database****
    Range("C1").FormulaR1C1 = "=COUNTIF(Database!R1C1:R2000C1,RC[-2])"
    Range("C1").AutoFill Destination:=Range("C1:C2000")
    Range("A2").CurrentRegion.Select
    ActiveSheet.Range("$a$1:$C$2000").AutoFilter Field:=3, Criteria1:="0"
    Set r = ActiveSheet.AutoFilter.Range
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1, 2)
    r.Copy
    Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    '******Data******
    Range("C1").FormulaR1C1 = "=COUNTIF(Data!R1C1:R2000C1,RC[-2])"
    Sheets(1).Range("C1").AutoFill Destination:=Range("C1:C2000")
    Range("A2").CurrentRegion.Select
    ActiveSheet.Range("$a$1:$C$2000").AutoFilter Field:=3, Criteria1:="0"
    Set r = ActiveSheet.AutoFilter.Range
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1, 2)
    r.Copy
    Sheets(3).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    '****clear data,filter *****
    Selection.AutoFilter
    Application.CutCopyMode = False
    Sheets(1).Range("C1:C2000").ClearContents
    Application.ScreenUpdating = True
End Sub

ลองแบบใช้ แมโครช่วยครับ

[bank9597]

ขอบคุณมากครับ ต้องขอเอาไปลองครับ