Board logo

標題: 列的複製/刪除與匯入 [打印本頁]

作者: hugh0620    時間: 2010-11-26 11:43     標題: 列的複製/刪除與匯入

Dear 大大們

     小弟遇到列的複雜/刪除與匯入上的問題
     詳述如下:
        我需要將
     1. Sheet1中有疑問的資料轉到sheet2中
     2. 將Sheet1中有疑問的資料刪除  (因Sheet2的資料澄清後,需要在匯回Sheet1中,會避免資料重覆的情況下,需要先行刪除)
       3.Sheet2的資料澄清後,需要在匯回Sheet1中  (還沒有寫)
     我在VBA寫法
    1.將Sheet1中有疑問的資料轉到sheet2中
     x = 0
       K = 0
       Do Until Sheet1.Cells(7 + x, 12) = ""
          If Sheet1.Cells(7 + x, 6) <> "" Then
             Sheet1.Rows(7 + x).Copy
             Sheet2.Select
             Sheet2.Rows(7 + k).Select
              ActiveSheet.Paste
              k = k + 1
           End If
        2. 將Sheet1中有疑問的資料刪除
      x = 0
         Do Until Sheet1.Cells(7 + x, 12) = ""
             For J = 0 To x
                If Sheet1.Cells(7 + J, 6) <> "" Then
                     Sheet1.Rows(7 + J).Delete
                End If
           Next J
             x = x + 1
          Loop
        可是這樣的寫法在執行上比較慢,請問大大是否有較好的方法
      另外第3.將資料匯回sheet1也有點卡住,盼能夠有提點一下
      這是我的寫法,不過我要貼的是從空白的地方接資料,但是執行後,檢查資料,卻沒有成功
      x = 0
         k = 0
         Do Until Sheet2.Cells(7 + x, 6) = ""
              If Sheet1.Cells(7 + k, 12) = "" Then
                 Sheet2.Rows(7 + x).Copy
                 Sheet1.Select
                 Sheet1.Rows(7 + k).Select
                 ActiveSheet.Paste
                  x = x + 1
               End If
               k = k + 1
         Loop
作者: Hsieh    時間: 2010-11-26 12:29

回復 1# hugh0620


    你的迴圈邏輯有點怪異,這樣的刪除列應該是不完整的
上傳您的檔案,解釋你所謂有疑問的資料條件
作者: hugh0620    時間: 2010-11-26 12:58

本帖最後由 hugh0620 於 2010-11-26 13:02 編輯

回復 2# Hsieh [attach]3794[/attach]

[ 大大 已經將附件放上sheet1中的F欄位就是資料有誤需要澄清的部份
作者: GBKEE    時間: 2010-11-26 16:00

回復 3# hugh0620
上傳檔案有問題打不開
作者: hugh0620    時間: 2010-11-26 18:40

回復 4# GBKEE


    有測試過可以打開~
    是打不開還是無法下載呢????
作者: oobird    時間: 2010-11-26 22:04

  1. Private Sub CommandButton1_Click()  '匯出與刪除
  2. With Sheet1
  3. .Range("f6:f" & .[g65536].End(3).Row).SpecialCells(2).EntireRow.Copy Sheet2.[a7]
  4. End With
  5. End Sub
複製代碼

作者: oobird    時間: 2010-11-26 23:20

忘了還有刪除:
Private Sub CommandButton1_Click()  '匯出與刪除
With Sheet1
.Range("f6:f" & .[g65536].End(3).Row).SpecialCells(2).EntireRow.Copy Sheet2.[a7]
.Range("f6:f" & .[g65536].End(3).Row).SpecialCells(2).EntireRow.delete
End With
End Sub
作者: GBKEE    時間: 2010-11-27 18:24

回復 5# hugh0620
你上傳檔案用特殊字元 造成下載後PC無法辨識檔案型態,無法自動用RAR檔案型態打開.
經開啟檔案時,用手動選擇RAR檔案型態開啟已解決.
  1. Private Sub CommandButton1_Click()  '匯出與刪除
  2.     With Sheet1.Range("f6").CurrentRegion.Columns(6).Offset(2)
  3.         On Error Resume Next
  4.         With .SpecialCells(2).EntireRow
  5.                 .Copy Sheet2.Range("A" & Sheet2.Range("F" & Rows.Count).End(xlUp).Row).Offset(1)
  6.                 .Delete
  7.         End With
  8.     End With
  9. End Sub
複製代碼

作者: hugh0620    時間: 2010-11-29 09:49

回復 7# oobird


    版主~..  謝謝您的回覆唷~ 不過小地在測試時,有點小小的問題存在~
                因如果使用者不小心再點到一次的話~ 該程式碼就會產生執行的錯誤....
作者: oobird    時間: 2010-11-29 11:00

我是很懶的人,總用懶方法處理事情。
你最好用GB版的,他的才是正統方式!
作者: hugh0620    時間: 2010-11-29 11:10

回復 8# GBKEE


    大大是高手,在測試上是ok的~ 只不過小弟無法吸收大大的功力~  (看不太懂)
    無法將大大的方式應用在後續實務上~   不過還是要感謝大大
作者: Hsieh    時間: 2010-11-29 14:09

回復 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    時間: 2010-11-30 14:55

回復 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    時間: 2010-11-30 20:35

代碼最前段加上關閉自動重算
在最尾段加上打開。
你可感覺速度飛快!
作者: hugh0620    時間: 2010-12-1 12:07

回復 14# oobird


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

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

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

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

是有加外很多~  還能夠在處理上加快嘛???
作者: oobird    時間: 2010-12-1 13:26

看你敘述的資料量應該幾秒內處理完的,如果你能提供文件的話。
作者: hugh0620    時間: 2010-12-1 15:02

回復 8# GBKEE


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

回復 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    時間: 2010-12-9 18:33

本帖最後由 hugh0620 於 2010-12-9 18:36 編輯

回復 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    時間: 2010-12-9 20:27

回復 19# hugh0620
若我的條件是F欄與K欄資料符合我刪除的條件,才進行刪除的動作
F欄與K欄的條件為何??
作者: hugh0620    時間: 2010-12-10 09:28

回復 20# GBKEE

         大大~ 我把需求做出一個例子~ 供大大了解我的問題

      附檔內 資料範圍 A~CL欄
          條件一  F欄等於X  且 CL等於1 就要刪掉
          條件二  O攔等於0 且 CL等於1 就要刪除
          上述兩個條件是會依需求分別執行,不是一次就執行

            (當我執行完後需要使用條件一時, 僅會執行條件一,而條件二不會執行)





                                [attach]4024[/attach]
作者: GBKEE    時間: 2010-12-10 12:15

回復 21# hugh0620
  1. Sub Ex()
  2.     With ActiveSheet
  3.         If .AutoFilter Is Nothing Then
  4.             .Rows(6).AutoFilter
  5.         Else
  6.             .Cells.AutoFilter
  7.             .Rows(6).AutoFilter
  8.         End If
  9.         With .Rows(6)
  10.             ''''''''''''''''''''''  請自行 修改判斷式
  11.             If ActiveSheet.[a1] = 1 Then              '條件一  F欄等於X  且 CL且等於1
  12.                 .AutoFilter 6, "=X"
  13.             ElseIf ActiveSheet.[a1] = 2 Then       '條件二  O攔等於0 且 CL等於1就要
  14.                 .AutoFilter 15, "=0"
  15.             End If
  16.             If ActiveSheet.[a1] = 1 Or ActiveSheet.[a1] = 2 Then   '''''''  請自行 修改判斷式
  17.                 .AutoFilter 90, "=1"
  18.                 .CurrentRegion.Offset(1).EntireRow.Delete
  19.             End If
  20.         '''''''''''''''''''''''''''''''''''''''
  21.         End With
  22.     End With
  23. End Sub
複製代碼

作者: hugh0620    時間: 2010-12-10 13:41

回復 22# GBKEE


      謝謝大大幫忙解決問題~ 我會測試一下~ 若有問題再請教大大
作者: hugh0620    時間: 2010-12-10 14:29

回復 22# GBKEE


    大大~ 執行結果~ 沒有任何刪除的動作~ 只有將篩選的資料全部解開~
             請大大示下~
作者: GBKEE    時間: 2010-12-10 15:58

回復 24# hugh0620
忘記 顯示顯示全部資料
  1.   Sub Ex()
  2.     With ActiveSheet
  3.         If .AutoFilter Is Nothing Then
  4.             .Rows(6).AutoFilter
  5.         Else
  6.             .Cells.AutoFilter
  7.             .Rows(6).AutoFilter
  8.         End If
  9.         With .Rows(6)
  10.             ''''''''''''''''''''''  請自行 修改判斷式
  11.             If ActiveSheet.[a1] = 1 Then              '條件一  F欄等於X  且 CL且等於1
  12.                 .AutoFilter 6, "=X"
  13.             ElseIf ActiveSheet.[a1] = 2 Then       '條件二  O攔等於0 且 CL等於1就要
  14.                 .AutoFilter 15, "=0"
  15.             End If
  16.             If ActiveSheet.[a1] = 1 Or ActiveSheet.[a1] = 2 Then   '''''''  請自行 修改判斷式
  17.                 .AutoFilter 90, "=1"
  18.                 .CurrentRegion.Offset(1).EntireRow.Delete
  19.             End If
  20.         '''''''''''''''''''''''''''''''''''''''
  21.         End With
  22.          .Cells.AutoFilter    '取消自動篩選 顯示顯示全部資料
  23.    End With
  24. End Sub
複製代碼

作者: hugh0620    時間: 2010-12-14 11:10

回復 25# GBKEE


    親愛滴大大~ 一樣還是沒有任何刪除的動作耶~ :dizzy:
作者: hugh0620    時間: 2010-12-14 11:26

本帖最後由 hugh0620 於 2010-12-14 11:28 編輯

回復 25# GBKEE

     大大請看~

     執行後還是無動靜~

    [attach]4082[/attach]
作者: GBKEE    時間: 2010-12-14 12:31

本帖最後由 GBKEE 於 2010-12-14 12:32 編輯

回復 27# hugh0620
ActiveSheet.[a1] 有 1 或 2 才會執行   
給你的程式碼要研究一下才會進步
''''''''''''''''''''''  請自行 修改判斷式
If ActiveSheet.[a1] = 1 Then              '條件一  F欄等於X  且 CL且等於1    ->  '請在  [a1] 輸入  1
    .AutoFilter 6, "=X"
ElseIf ActiveSheet.[a1] = 2 Then       '條件二  O攔等於0 且 CL等於1就要 2  ->  '請在  [a1] 輸入  2   
   .AutoFilter 15, "=0"
End If
If ActiveSheet.[a1] = 1 Or ActiveSheet.[a1] = 2 Then   '''''''  請自行 修改判斷式      .
           . AutoFilter 90, "=1"
          .CurrentRegion.Offset(1).EntireRow.Delete
  End If
作者: hugh0620    時間: 2010-12-14 14:32

回復 28# GBKEE


    大大~ 您說的是~ 很對不起~ 沒有好好研究你提供的方式~

    下次會改進~

     也是大大再一次提省了我~ 我終於有仔細看了大大寫的~ 了解大大程式碼的意思~

     謝謝大大~




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)