麻辣家族討論版版 - Powered by Discuz! Board

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

作者: 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

Private Sub CommandButton1_Click() '匯出與刪除
With Sheet1
.Range("f6:f" & .[g65536].End(3).Row).SpecialCells(2).EntireRow.Copy Sheet2.[a7]
End With
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檔案型態開啟已解決.

Private Sub CommandButton1_Click() '匯出與刪除
With Sheet1.Range("f6").CurrentRegion.Columns(6).Offset(2)
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

複製代碼

作者: 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
以你原程式碼的刪除動作應該要由後往前刪除

Private Sub CommandButton1_Click() '匯出與刪除
Dim A As Range
With Sheet1
r = .[L65536].End(xlUp).Row
Do Until r < 7
If .Cells(r, 6) <> "" Then
.Rows(r).Copy Sheet2.Cells(k + 7, 1) '匯出
.Rows(r).Delete xlShiftUp '刪除
k = k + 1
End If
r = r - 1
Loop
End With
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

Private Sub CommandButton1_Click() '刪除
Dim A As Range, Rng As Range
If Application.CountA([F6:F65536]) > 0 Then
For Each A In Range("F6:F65536").SpecialCells(xlCellTypeConstants)
If A.Offset(, 9) = 0 Or A.Offset(, 83) = 0 Then
If Rng Is Nothing Then
Set Rng = A
Else
Set Rng = Union(Rng, A)
End If
End If
Next
End If
Rng.EntireRow.Delete
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

Sub Ex()
With ActiveSheet
If .AutoFilter Is Nothing Then
.Rows(6).AutoFilter
Else
.Cells.AutoFilter
.Rows(6).AutoFilter
End If
With .Rows(6)
'''''''''''''''''''''' 請自行修改判斷式
If ActiveSheet.[a1] = 1 Then '條件一 F欄等於X 且 CL且等於1
.AutoFilter 6, "=X"
ElseIf ActiveSheet.[a1] = 2 Then '條件二 O攔等於0 且 CL等於1就要
.AutoFilter 15, "=0"
End If
If ActiveSheet.[a1] = 1 Or ActiveSheet.[a1] = 2 Then ''''''' 請自行修改判斷式
.AutoFilter 90, "=1"
.CurrentRegion.Offset(1).EntireRow.Delete
End If
'''''''''''''''''''''''''''''''''''''''
End With
End With
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
忘記顯示顯示全部資料

Sub Ex()
With ActiveSheet
If .AutoFilter Is Nothing Then
.Rows(6).AutoFilter
Else
.Cells.AutoFilter
.Rows(6).AutoFilter
End If
With .Rows(6)
'''''''''''''''''''''' 請自行修改判斷式
If ActiveSheet.[a1] = 1 Then '條件一 F欄等於X 且 CL且等於1
.AutoFilter 6, "=X"
ElseIf ActiveSheet.[a1] = 2 Then '條件二 O攔等於0 且 CL等於1就要
.AutoFilter 15, "=0"
End If
If ActiveSheet.[a1] = 1 Or ActiveSheet.[a1] = 2 Then ''''''' 請自行修改判斷式
.AutoFilter 90, "=1"
.CurrentRegion.Offset(1).EntireRow.Delete
End If
'''''''''''''''''''''''''''''''''''''''
End With
.Cells.AutoFilter '取消自動篩選顯示顯示全部資料
End With
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/)