jsc0518

帖子: 455
主題: 111
精華: 0
積分: 563
點名: 180
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2013-11-7
最後登錄: 2026-10-4

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章論壇贊助勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2022-3-22 20:14 | 只看該作者

[發問] 刪除整列有資料無底色

Dear all,
此資料以A欄列為主，當A欄列下底色有顏色時，該列保留。
其餘有資料但無底色，"整列刪除"。
還請大家幫忙
示意圖如下

原始資料

想要的狀況

刪除有資料無底色的列.rar (7.53 KB)

樓主熱帖

Just do it.

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

2^#

發表於 2022-3-23 08:13 | 只看該作者

回復 1# jsc0518

請測試看看，謝謝
Sub test()
Dim xR As Range, R%, Clr
Application.ScreenUpdating = False
R = 1
With Sheets(1)
If .AutoFilterMode Then .[a1].AutoFilter
For Each xR In .Range(.[a1], .Cells(.Rows.Count, 1).End(3))
      Clr = xR.DisplayFormat.Interior.ColorIndex
      If Clr <> -4142 Then
         xR.Resize(, 1).Copy Sheets(2).Cells(R, 1)
         R = R + 1
      End If
Next
End With
Application.ScreenUpdating = True
End Sub

TOP

jsc0518

高中生 Rank: 3 Rank: 3

帖子: 455
主題: 111
精華: 0
積分: 563
點名: 180
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2013-11-7
最後登錄: 2026-10-4

2025年全勤獎章 2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章論壇贊助勳章

3^#

發表於 2022-3-23 20:38 | 只看該作者

回復 2# samwang
Dear samwang,
您好，我想要在"原始資料"工作表下直接刪除無底色(有資料)的列(整列)
同一工作上執行，執行結果不需在複製到另一工作表上。
感謝您！:)

Just do it.

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

4^#

發表於 2022-3-24 07:43 | 只看該作者

本帖最後由 samwang 於 2022-3-24 07:51 編輯

回復 samwang
Dear samwang,
您好，我想要在"原始資料"工作表下直接刪除無底色(有資料)的列(整列)
同一 ...
jsc0518 發表於 2022-3-23 20:38

請再測試看看，謝謝
Sub test2()
Dim xR As Range, xU As Range, Clr
Application.ScreenUpdating = False
With Sheets(1)
If .AutoFilterMode Then .[a1].AutoFilter
For Each xR In .Range(.[a1], .Cells(.Rows.Count, 1).End(3))
      Clr = xR.DisplayFormat.Interior.ColorIndex
      If Not Clr <> -4142 Then
         If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
      End If
Next
End With
If Not xU Is Nothing Then xU.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

TOP

jsc0518