ช่วยตรวจสอบไฟล์ว่า ทำงานช้าหรือไม่ครับ

[tigerwit]

จากไฟล์ที่แนบมา
มีโค๊ดสำหรับส่งข้อมูล และเคลียร์ข้อมูลในเซลล์
ซึ่งมีจำนวนแถวในการส่งข้อมูลไปอีกชีท ไม่มากนัก ไม่เกิน 25 แถว
มีความรู้สึกว่าไฟล์ทำงานช้า (เครื่องที่ใช้ I5 73000 Ram 16)
แค่ส่งข้อมูลข้ามชีท 10 แถวใช้เวลา เกือบ 2 นาที

[snasui]

กรุณาแจ้ง Password ในการเข้าถึง Code ด้วยครับ

กรณีข้อมูลสำคัญให้แปลงไปเป็นข้อมูลอื่นแล้ว Save As มาเป็นไฟล์ใหม่แทนครับ

[tigerwit]

ผมลืมปลดล็อคครับ
ใช้ไฟล์นี้ครับผม

[snasui]

ไฟล์นี้มีสูตรที่ทำงานหนักจำนวนมาก เช่น Frequency ร่วมกับ Index, Small หรือใช้ใน Aggregate เมื่อรวมกับสูตรอื่น ๆ แล้วมีถึง 29,077 สูตรที่เป็นภาระให้กับไฟล์ การปรับให้ทำงานเร็วควรใช้ Code มาช่วยทำงานแทนสูตรที่ทำงานหนัก ๆ ครับ

สิ่งสำคัญในการในการทำงานด้วย Code ควรปิดการคำนวณให้เป็น Manual เสียก่อนเพื่อหลีกเลี่ยงการเปลี่ยนไปคำนวณไป ทำงานเสร็จแล้วค่อยเปิดการคำนวณกลับมาเป็น Automatic เสียใหม่เพื่อคำนวณพร้อมกันทีเดียว

ลักษณะของ Code ก็จะเป็นเช่นด้านล่างครับ

Code: Select all

'Other code
Application.Calculation = xlCalculationManual
Range("E9:F33").ClearContents
For i = 2 To 5000
    If Sheets("database").Range("A" & i).Value = Sheets("baibake").Range("M8") Then
        Sheets("database").Range("D" & i).Copy
        Sheets("baibake").Range("E" & Rows.Count).End(xlUp).Offset(1, 0) _
        .PasteSpecial xlPasteValues
        Sheets("database").Range("G" & i).Copy
        Sheets("baibake").Range("F" & Rows.Count).End(xlUp).Offset(1, 0) _
        .PasteSpecial xlPasteValues
    End If
Next i
Range("M2").Select
Application.Calculation = xlCalculationAutomatic
'Other code

[tigerwit]

ขอบคุณมากครับ
ได้ลองทำตามคำแนะนำแล้ว
จากไฟล์ที่แนบมา
1. ต้องการส่งข้อมูลจาก sheet1 ไปไว้ที่ Sheet2 ที่คลอลัมน์ Q ต้องปรับแก้อย่างไรครับ
2. ที่ sheet3 ถ้าคลอลัมน์ที่ค้นหาเปลี่ยนเป็น คลอลัมน์ D และคลอลัมน์ที่จะวางค่า เป็นคลอลัมน์ Q อย่างไร

Code: Select all

Sub Duplicate()
Dim lngLastRow As Long, lngLoopRow As Long
Dim lngWriteRow As Long
Dim rngFindRange
lngWriteRow = 2
lngLastRow = Cells(Rows.Count, 2).End(xlUp).Row

Range("D2:D" & lngLastRow).ClearContents
For lngLoopRow = lngLastRow To 2 Step -1
    With Cells(lngLoopRow, 2)
        If Application.WorksheetFunction.CountIf(Range("B2:B" & lngLastRow), .Value) > 1 Then
            If Range("D:D").Find(.Value, lookat:=xlWhole) Is Nothing Then
                Cells(lngWriteRow, 4) = .Value
                lngWriteRow = lngWriteRow + 1
            End If
        End If
    End With
Next lngLoopRow
End Sub

[snasui]

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

Code: Select all

Sub Test0()
    With Sheets("Sheet2")
        .Range("b:b").Value = Sheets("Sheet1").Range("b:b").Value
        With .Range("b2").CurrentRegion
            .RemoveDuplicates Columns:=1, Header:=xlNo
        End With
    End With
End Sub

[tigerwit]

ขอบพระคุณครับ
ทดสอบตามโค๊ดที่แนะนำ
ไม่ทราบว่าทำไมถึงมาหมด

[snasui]

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

Code: Select all

'Other code
With .Range("B2", .Range("b" & .Rows.Count).End(xlUp))
    .RemoveDuplicates Columns:=1, Header:=xlNo
End With
'Other code

[tigerwit]

ใช้งานได้แล้วครับ ขอบคุณครับ

สอบถามเพิ่มเติมครับว่า รกณีกรณีของไฟล์นี้
เราจัดรูปแบบปลายทางไว้อย่างหนึ่งพอดึงข้อมูลไปวางแล้ว
รูปแบบที่จัดไว้เปลี่ยนไป เกิดจากสาเหตุใด และจะมีวิธีแก้ไขอย่างไรครับ
(ชีท Database คลอลัมน์ Q จะเปลี่ยนเป็ํนรูปวันที่ จัดรูปแบบใหม่ให้เป็นข้อความแล้ว
พอดึงข้อมูลอีกครั้งก็เปลี่ยนไปเหมือนเดิม)

[snasui]

ตัวอย่างการปรับ Code เพื่อให้แสดงรูปแบบเป็น Text พร้อมหมายเลขกำกับบรรทัดเป็นค่าคงที่แทนสูตรครับ

Code: Select all

Sub AStock()
    With Sheets("Database")
        .Columns("p").Clear
        .Range("q:q").NumberFormat = "@"
        .Range("Q:Q").Value = .Range("A:A").Value
        With .Range("Q2", .Range("Q" & .Rows.Count).End(xlUp))
            .RemoveDuplicates Columns:=1, Header:=xlNo
        End With
        If .Range("q2").Value <> "" Then
            With .Range("q2").CurrentRegion.Offset(0, -1)
                .Formula = "=Rows(r2c:rc)"
                .Value = .Value
            End With
        End If
    End With
End Sub