hugh0620

回復 8# GBKEE


    大大是高手,在測試上是ok的~ 只不過小弟無法吸收大大的功力~  (看不太懂)
    無法將大大的方式應用在後續實務上~   不過還是要感謝大大

Hsieh

回復 11# hugh0620
以你原程式碼的刪除動作應該要由後往前刪除

1. Private Sub CommandButton1_Click()  '匯出與刪除
   
2. Dim A As Range
   
3. With Sheet1
   
4. r = .[L65536].End(xlUp).Row
   
5. Do Until r < 7
   
6.    If .Cells(r, 6) <> "" Then
   
7.       .Rows(r).Copy Sheet2.Cells(k + 7, 1) '匯出
   
8.         .Rows(r).Delete xlShiftUp '刪除
   
9.        k = k + 1
   
10.    End If
    
11.    r = r - 1
    
12. Loop
    
13. End With
    
14. End Sub

複製代碼

hugh0620

回復 12# Hsieh

版主~ 我有將你的寫法改成我實際要用的方式,因我在執行時,有三個條件要先匯出,這方面的執行速度上ok~ 很快~
          但在刪除上,若是用版主的方法,每刪除一筆資料會重新計算儲存格導致執行時變很慢
       我將刪除的部份修改成下列的方式,可執行,但很慢                            (我的資料量約5000列*89欄的資料需要處理)

    Private Sub CommandButton1_Click()  '刪除
        With Sheet1
            r = .[L65536].End(xlUp).Row
               Do Until r < 7
                  If .Cells(r, 6) <> "" or Cells(r, 15) = 0 or Cells(r, 89) = 0  Then
                    .Rows(r).Delete xlShiftUp '刪除
                    End If
                          r = r - 1
              Loop
      End With
End Sub

oobird

代碼最前段加上關閉自動重算
在最尾段加上打開。
你可感覺速度飛快！

hugh0620

回復 14# oobird


    版主大大~ 小弟有試過將自動儲存格先行關閉,再打開

  在原程式碼前加上 application.calculation = xlcalculationManual

   在原程式碼前後上 application.calculation = xlcalculationAutomatic

  執行的結果,從原本的快20分鐘左右 減 至 7分鐘

是有加外很多~  還能夠在處理上加快嘛???

oobird

看你敘述的資料量應該幾秒內處理完的，如果你能提供文件的話。

hugh0620

回復 8# GBKEE


    謝謝大大~ 雖然還是不太懂你寫的方法~ 但小弟終於測試到最後~ 可以應用在我需要的工作上~
    使我處理速度上快很多~ 感恩~

Hsieh

回復 17# hugh0620

1. Private Sub CommandButton1_Click()  '刪除
   
2. Dim A As Range, Rng As Range
   
3. If Application.CountA([F6:F65536]) > 0 Then
   
4. For Each A In Range("F6:F65536").SpecialCells(xlCellTypeConstants)
   
5.    If A.Offset(, 9) = 0 Or A.Offset(, 83) = 0 Then
   
6.       If Rng Is Nothing Then
   
7.         Set Rng = A
   
8.         Else
   
9.         Set Rng = Union(Rng, A)
   
10.       End If
    
11.     End If
    
12. Next
    
13. End If
    
14. Rng.EntireRow.Delete
    
15. End Sub

複製代碼

hugh0620

回復 8# GBKEE


    大大~ 想再請問你一個問題~
            大大原程式的寫法~ 是針對一個條件下去刪除~
            若小弟需要同一列上要符合兩個條件下才做刪除的動作~
            該如何修改程式碼呢????


Private Sub CommandButton1_Click()  '匯出與刪除
    With Sheet1.Range("f6").CurrentRegion.Columns(6).Offset(2)      <--- 若我的條件是F欄與K欄資料符合我刪除的條件,才進行刪除的動作
        On Error Resume Next
        With .SpecialCells(2).EntireRow
                .Copy Sheet2.Range("A" & Sheet2.Range("F" & Rows.Count).End(xlUp).Row).Offset(1)
                .Delete
        End With
    End With
End Sub

GBKEE

回復 19# hugh0620
若我的條件是F欄與K欄資料符合我刪除的條件,才進行刪除的動作
F欄與K欄的條件為何??