　暱稱: VBA向前衝

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 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

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 255
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-25

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2010-11-26 12:29 | 只看該作者

回復 1# hugh0620

你的迴圈邏輯有點怪異，這樣的刪除列應該是不完整的
上傳您的檔案，解釋你所謂有疑問的資料條件

學海無涯_不恥下問

TOP

hugh0620

　暱稱: VBA向前衝

高中生 Rank: 3 Rank: 3

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

3^#

發表於 2010-11-26 12:58 | 只看該作者

[版主管理留言]

Hsieh(2010-11-27 00:23): 檔名勿使用特殊符號

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

回復 2# Hsieh

列的複製&刪除與匯入.rar (55.79 KB)

[ 大大已經將附件放上sheet1中的F欄位就是資料有誤需要澄清的部份

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2010-11-26 16:00 | 只看該作者

回復 3# hugh0620
上傳檔案有問題打不開

TOP

hugh0620

　暱稱: VBA向前衝

高中生 Rank: 3 Rank: 3

帖子: 559
主題: 58
精華: 0
積分: 626
點名: 0
作業系統: win8
軟體版本: office2013
閱讀權限: 50
性別: 男
來自: TW
註冊時間: 2010-11-22
最後登錄: 2024-6-14

5^#

發表於 2010-11-26 18:40 | 只看該作者

回復 4# GBKEE

有測試過可以打開~
是打不開還是無法下載呢????

TOP

oobird

　頭銜: 街友一族

超級版主 Rank: 8 Rank: 8

帖子: 1572
主題: 16
精華: 2
積分: 1521
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 150
性別: 男
註冊時間: 2010-5-1
最後登錄: 2016-1-13

論壇貢獻勳章

6^#

發表於 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

複製代碼

TOP

oobird

　頭銜: 街友一族

超級版主 Rank: 8 Rank: 8

帖子: 1572
主題: 16
精華: 2
積分: 1521
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 150
性別: 男
註冊時間: 2010-5-1
最後登錄: 2016-1-13

論壇貢獻勳章

7^#

發表於 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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

8^#

發表於 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

複製代碼

TOP

hugh0620