[發問] 詢問欄位中有刪除線及空白需先篩選後，搭配vlookup取得資料有沒有更好的方法

帖子: 30
主題: 12
精華: 0
積分: 147
點名: 0
作業系統: WIN 11
軟體版本: OFFICE365
閱讀權限: 20
性別: 女
註冊時間: 2010-5-7
最後登錄: 2023-12-4

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2023-11-23 10:54 | 只看該作者

[發問] 詢問欄位中有刪除線及空白需先篩選後，搭配vlookup取得資料有沒有更好的方法

資料規則如下圖:

情境資料下載:

測試.zip (10.37 KB)

"情境呈現結果貼上固定欄位資料，只取非空白欄位對應的數值，再用數值找出對應的字串"

篩選點:
1.字有刪除線篩選掉
2.空白格對應的數值不要取

我目前作法是先尋找欄位中有刪除線先塗上背景黃色(vba函數)，再用

=FILTER(B2:B257,B2:B257<>"")

複製代碼

找出非空白對應的值

這邊的搭配就卡住，不會用vlookup將上兩個結合

樓主熱帖

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

2^#

發表於 2023-11-24 08:10 | 只看該作者

回復 1# 爆肝達人

謝謝論壇,謝謝前輩發表此主題與範例
後學藉此帖學習以前前輩們的問答,學到很多知識
https://forum.twbts.com/viewthre ... =Font.Strikethrough

以下學習的方案,請前輩參考
如果數字有重複只取第1筆對應字串

執行結果:

Option Explicit
Sub TEST()
Dim A As Range, i%, Z
Set Z = CreateObject("Scripting.Dictionary")
For Each A In Intersect(ActiveSheet.UsedRange, [B:B,D:D,F:F]).SpecialCells(2)
If A.Item(1, 0) = "" Then GoTo A01
For i = 1 To Len(A & "")
If A.Characters(i, 1).Font.Strikethrough = True Then GoTo A01
Next
If Z(Val(A.Item(1, 0))) = "" Then Z(Val(A.Item(1, 0))) = A
A01: Next
With [H2].Resize(Z.Count, 2)
Intersect(ActiveSheet.UsedRange, .EntireColumn).Offset(1).ClearContents
.Columns(1) = Application.Transpose(Z.Keys)
.Columns(2) = Application.Transpose(Z.Items)
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
End With
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

帖子: 30
主題: 12
精華: 0
積分: 147
點名: 0
作業系統: WIN 11
軟體版本: OFFICE365
閱讀權限: 20
性別: 女
註冊時間: 2010-5-7
最後登錄: 2023-12-4

3^#

發表於 2023-11-24 10:05 | 只看該作者

回復爆肝達人

謝謝論壇,謝謝前輩發表此主題與範例
後學藉此帖學習以前前輩們的問答,學到很多知 ...
Andy2483 發表於 2023-11-24 08:10

謝謝前輩，符合需求，謝謝

帖子: 30
主題: 12
精華: 0
積分: 147
點名: 0
作業系統: WIN 11
軟體版本: OFFICE365
閱讀權限: 20
性別: 女
註冊時間: 2010-5-7
最後登錄: 2023-12-4

4^#

發表於 2023-11-24 10:45 | 只看該作者

資料更新問題，不使用巨集的情況

貼上新的A1至H1資料，我能讓他自動更新篩選後的資料顯示在欄位上，
我目前想到是按下Button，vba放入在button中，有其它更好的方法嗎?

謝謝

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

5^#

發表於 2023-11-24 15:48 | 只看該作者

回復 4# 爆肝達人

謝謝前輩回復
以下是練習觸發呼叫副程式的方案,請前輩參考

測試_20231124.zip (16.32 KB)

工作表模組
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If Intersect(.Cells, [A:F]) Is Nothing Then Exit Sub Else Call Ex
End With
End Sub

一般模組:
Option Explicit
Sub Ex()
Dim Arr, A, i%, Z
Set Z = CreateObject("Scripting.Dictionary")
Set Arr = CreateObject("System.Collections.ArrayList")
For Each A In Intersect(ActiveSheet.UsedRange, [B:B,D:D,F:F]).SpecialCells(2)
If A.Item(1, 0) = "" Then GoTo A01
For i = 1 To Len(A & "")
If A.Characters(i, 1).Font.Strikethrough = True Then GoTo A01
Next
If Z(Val(A.Item(1, 0))) = "" Then Z(Val(A.Item(1, 0))) = A
A01: Next
For Each A In Z.Keys
If A <> vbNullString And Not Arr.contains(A) Then Arr.Add (A)
Next
Arr.Sort: Arr = Arr.toarray
ReDim A(UBound(Arr), 1 To 2)
For i = 0 To UBound(Arr): A(i, 1) = Arr(i): A(i, 2) = Z(Arr(i)): Next
With [H2].Resize(Z.Count, 2)
Intersect(ActiveSheet.UsedRange, .EntireColumn).Offset(1).ClearContents
.Value = A
End With
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

帖子: 30
主題: 12
精華: 0
積分: 147
點名: 0
作業系統: WIN 11
軟體版本: OFFICE365
閱讀權限: 20
性別: 女
註冊時間: 2010-5-7
最後登錄: 2023-12-4

6^#

發表於 2023-11-27 10:49 | 只看該作者

回復 5# Andy2483

前輩非常感恩，已解決。