Board logo

標題: [發問] vba特定格式刪除 [打印本頁]
作者: man65boy    時間: 2016-6-3 09:56     標題: vba特定格式刪除

如何把清冊中的特定格式刪除(標是顏色部份)，在資料往上遞補，因為每一階段的資料有所不同，所以表格上的每列資料不相同(沒有固定)，請老師幫忙，謝謝!
附檔解題:[attach]24402[/attach]
作者: Kubi    時間: 2016-6-3 13:31

Sub test()
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        er = .[J65536].End(3).Row
        For r = er To 1 Step -1
            If .Cells(r, 1).Interior.ColorIndex = 4 Then Rows(r).Delete
        Next r
    End With
    Application.ScreenUpdating = True
End Sub
作者: man65boy    時間: 2016-6-3 19:42

回復 2# Kubi


    感謝Kubi大大的回答，刪除的很整確，但 再拜託一下，還有另一種格式，所以程式沒法用，另一個問題在SHEEET2 ，刪除的方式，根SHEET1一樣，附檔:[attach]24410[/attach]
    謝謝!
作者: Kubi    時間: 2016-6-3 20:46

Sub test2()
    Application.ScreenUpdating = False
    With Sheets("Sheet2")
        er = .[I65536].End(3).Row
        For r = er To 1 Step -1
            If .Cells(r, 10).Interior.ColorIndex = 4 Then Rows(r).Delete
        Next r
    End With
    Application.ScreenUpdating = True
End Sub
作者: GBKEE    時間: 2016-6-4 06:11

回復 3# man65boy

試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng(1 To 2) As Range, Sh As Worksheet
  4.     For Each Sh In Sheets  ' Sheets 物件: 活頁簿Sheet的物件集合
  5.         Set Rng(1) = Sh.Cells.Find(Sh.Range("a4"), Sh.Range("a4")) ' [物品編號 ]所在列:為所有工作表表單上的共通點
  6.         If Not Rng(1) Is Nothing Then '工作表上有尋找到 [物品編號 ]
  7.             Set Rng(2) = Nothing
  8.             Do
  9.                 If Rng(2) Is Nothing Then
  10.                     Set Rng(2) = Rng(1).Offset(-3).Resize(4).EntireRow     '[物品編號 ]所在列 ,往上4列儲存格的整列
  11.                 Else
  12.                     Set Rng(2) = Union(Rng(2), Rng(1).Offset(-3).Resize(4).EntireRow)  ''整合:[物品編號 ]所在列 ,往上4列儲存格的整列
  13.                 End If
  14.                 Set Rng(1) = Sh.Cells.FindNext(Rng(1))
  15.             Loop Until Rng(1).Address(0, 0) = "A4"
  16.             If Not Rng(2) Is Nothing Then Rng(2).Delete   '刪除
  17.         End If
  18.     Next
  19. End Sub
複製代碼
作者: c_c_lai    時間: 2016-6-4 08:58

回復 5# GBKEE
Rng(1) 、Rng(2) 以及 Union() 的處裡蠻細膩及扼要，
一針見血，簡明俐落。
謝謝您的賜教！
作者: man65boy    時間: 2016-6-4 10:42

回復 5# GBKEE

謝謝Kubi大大和GBKEE超級板大的回答，非常的符合，但 又是不材小弟以為用個類似的表格就可利用程式來應用，真得實在太不材了，搞了好久，還是.........不行，
小弟把原始檔修改文字而已，再請老師們幫幫忙看一下，真得很感謝，又拍事。附檔:[attach]24416[/attach]
作者: c_c_lai    時間: 2016-6-4 11:24

回復 7# man65boy
套用 GBKEE 大大的程式碼，並加上
  1.          If Sh.Range("a4") <> "" Then
  2.             .
  3.             .
  4.          End If
複製代碼
來過濾空白內容的表單：
  1. Sub Ex()
  2.     Dim Rng(1 To 12) As Range, Sh As Worksheet
  3.     For Each Sh In Sheets  ' Sheets 物件: 活頁簿Sheet的物件集合
  4.         If Sh.Range("a4") <> "" Then
  5.             Set Rng(1) = Sh.Cells.Find(Sh.Range("a4"), Sh.Range("a4")) ' [物品編號 ]所在列:為所有工作表表單上的共通點
  6.             If Not Rng(1) Is Nothing Then '工作表上有尋找到 [物品編號 ]
  7.                 Set Rng(2) = Nothing
  8.                 Do
  9.                     If Rng(2) Is Nothing Then
  10.                         Set Rng(2) = Rng(1).Offset(-3).Resize(4).EntireRow     '[物品編號 ]所在列 ,往上4列儲存格的整列
  11.                     Else
  12.                         Set Rng(2) = Union(Rng(2), Rng(1).Offset(-3).Resize(4).EntireRow)  ''整合:[物品編號 ]所在列 ,往上4列儲存格的整列
  13.                     End If
  14.                     Set Rng(1) = Sh.Cells.FindNext(Rng(1))
  15.                 Loop Until Rng(1).Address(0, 0) = "A4"
  16.                 If Not Rng(2) Is Nothing Then Rng(2).Delete   '刪除
  17.             End If
  18.         End If
  19.     Next
  20. End Sub
複製代碼
作者: man65boy    時間: 2016-6-4 15:22

本帖最後由 man65boy 於 2016-6-4 15:25 編輯

回復 8# c_c_lai

謝謝老師的幫忙，如果我把A4的儲存格文字(物品編號)改為(日期)，為何無法執行，再程式碼:Set Rng(1) = Sh.Cells.Find(Sh.Range("a4"), Sh.Range("a4")) ' [物品編號 ]所在列:為所有工作表表單上的共通點 ，不是都依A4的儲存格為主了嗎?怎麼我把所有"物品編號"改為"(日期)"，會無法執行???(執行階段錯誤'1004')
作者: Kubi    時間: 2016-6-4 20:11

回復 9# man65boy
另外一種解法，請參考
[attach]24425[/attach]。
作者: c_c_lai    時間: 2016-6-4 20:19

回復 9# man65boy
如果你想要將 A4 的儲存格文字 (物品編號) 改為 (日期)，
理論上是 OK 的。
但是在你的 A3 欄位的值是 Rng(1) = "           製表日期: " : Range/Range
程式在最後一次執行 Set Rng(1) = Sh.Cells.FindNext(Rng(1)) 時，
回頭搜尋 (FindNext()) 卻抓到了A3 欄位的值，而非 A4 的儲存格文字 (日期)。

接著 程式繼續往下執行到
Set Rng(2) = Union(Rng(2), Rng(1).Offset(-3).Resize(4).EntireRow)
在 Rng(1).Offset(-3) 便產出了錯誤訊息 ('1004')；因為此時
Rng(1).Address(0, 0) = "A3" : String， 而 Rng(1).Offset(-3) 的位址為 A0，
已經超出表單的範圍。
作者: GBKEE    時間: 2016-6-5 05:55

回復 11# c_c_lai
8#的程式碼 修改 搜尋完全一樣的字串
   
  1. Set Rng(1) = Sh.Cells.Find(Sh.Range("a4"), Sh.Range("a4"), LookAt:=xlWhole)
  2. ' 加上這參數 , XlLookAt 常數之一：xlWhole 或 xlPart。
複製代碼
作者: c_c_lai    時間: 2016-6-5 07:02

回復 9# man65boy
就如 GBKEE 大大的提示 (#12) 做修正，
便 OK 了！
作者: man65boy    時間: 2016-6-5 13:41

回復 13# c_c_lai

謝謝大大和版主的回覆，那如果改用固定列的刪除法要如何用，意思是，工作表上的1~3列刪除，41~45列刪除，82~86，123~127刪除......以此類推，(資料我看大致上除了第一頁的資料是37列外，其餘都是36列)
然後再把資造整合在一起，這樣可能比較單純，謝謝老師們幫忙，附檔[attach]24430[/attach]
作者: c_c_lai    時間: 2016-6-5 20:48

回復 14# man65boy
你認為處理的思考方向 OK 的話，就以你的想法去達成它。
論壇只是一個釋疑與學習的場合，每個人均有自己的思考方向，
只要是好的詮釋、或是更佳的技巧處理都是值得我們學習的。
作者: GBKEE    時間: 2016-6-6 08:48

回復 14# man65boy
試試看
  1. Sub Ex()
  2.     Dim Sh As Worksheet, Rng As Range
  3.     On Error Resume Next  '程式有錯誤不理會,繼續執行下去
  4.     For Each Sh In Worksheets
  5.         Set Rng = Sh.UsedRange.Columns("I:I").Offset(4)  'Columns("I:I") 工作表資料的最後一欄 ,Offset(4) 資料第五列開始
  6.         Rng.MergeCells = False                                          '取消合併的儲存格
  7.         Rng.Value = Rng.Value                                         '儲存格的格式設為 數字
  8.         Set Rng = Union(Rng.SpecialCells(xlCellTypeBlanks), Rng.SpecialCells(xlCellTypeConstants, xlTextValues))
  9.          'xlCellTypeBlanks 空白的儲存格, SpecialCells(xlCellTypeConstants, xlTextValues)  '文字的儲存格
  10.          'UsedRange.Columns("I:I").Offset(4) 儲存格中 沒有 [空白的],[文字的] 程式會錯誤
  11.         If Err = 0 Then Rng.EntireRow.Delete
  12.         If Err > 0 Then Err.Clear
  13.     Next
  14. End Sub
複製代碼
作者: man65boy    時間: 2016-6-6 11:00

回復 15# c_c_lai

謝謝c_c_lai大大的幫忙，給小弟有更多可應用的範本與方法，
c_c_lai大大說的:每個人均有自己的思考方向，
只要是好的詮釋、或是更佳的技巧處理都是值得我們學習的。
所言甚是阿，牢記在心底。謝謝你!!!
作者: man65boy    時間: 2016-6-6 11:06

回復 16# GBKEE

感謝GBKEE板大的回答，非常的符合表單的需求，因為原始檔牽涉到物件機密，致使不敢上傳真正的問題格式，真的只能稍佳修改上傳發問，但沒想到問題不是普通雜，經2位老師的幫忙， 也給小弟有更多的學習知識，真的感謝你們，感恩!



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