軒云熊

回復 1# abc9gad2016
這是參考  jcchiang 大大的寫法 有空看看是不是這樣 感謝

1. Public Sub 尋找相對欄位練習()
   
2. 
   
3.     Arr = [工作表1!A1].CurrentRegion
   
4.     Set xD = CreateObject("Scripting.Dictionary")
   
5.    
   
6.     For Y = 1 To UBound(Arr, 2)
   
7.         xD(Arr(2, Y)) = Y
   
8.     Next Y
   
9.    
   
10.     For X = 3 To UBound(Arr, 1)
    
11.         For Y = 2 To UBound(Arr, 2)
    
12.             If Arr(X, 1) = [尋找!A2] And Arr(X, Y) <> "" Then
    
13.                 E = E + 1
    
14.                 Sheets(2).Cells(2, 1 + E) = Arr(2, xD(Arr(2, Y)))
    
15.             End If
    
16.         Next Y
    
17.     Next X
    
18. 
    
19. End Sub

複製代碼

軒云熊

回復 3# samwang


感謝 samwang 前輩的指導 小弟受益良多  請問  samwang前輩  T & ""  為甚麼要串連空白  & "" 的用意是甚麼
可否說明一下  我不太理解 因為字典不是那麼直觀

軒云熊

回復 5# samwang

謝謝samwang前輩的回覆 學習了  感謝

軒云熊

回復 11# abc9gad2016

Public Sub 尋找相對欄位練習()
    Application.ScreenUpdating = False
    Range(Sheets(2).Cells(2, 2).End(xlToRight), Sheets(2).Cells(2, 2)).ClearContents
    Arr = Range(Sheets(1).Cells(Rows.Count, 1).End(xlUp), Sheets(1).Cells(6, 1).End(xlToRight))
    Set xD = CreateObject("Scripting.Dictionary")
   
    For Y = 1 To UBound(Arr, 2)
        xD(Arr(1, Y)) = Y
    Next Y
   
    For X = 3 To UBound(Arr, 1)
        For Y = 6 To UBound(Arr, 2)
            If Arr(X, 1) = [尋找!A2] And Arr(X, Y) <> "" Then
                E = E + 1
                Sheets(2).Cells(2, 1 + E) = Arr(1, xD(Arr(1, Y)))
            End If
        Next Y
    Next X
    Application.ScreenUpdating = True
End Sub

建議 修改 samwang 大大的位置 比較好 他的寫法 比我的好很多