Piny-Lookup的應用(VBA)

piny

感謝藍老師及趙老師的協助，小弟工作所需已完成約一半，本來想以下拉完成，經藍老師建議改以本頁皆以VBA完成，考量閱讀便利性，另開新帖求問。

原連結
http://club.excelhome.net/thread-739394-1-1.html

問題一：利用VBA寫出下述公式，請與基準分析寫在同一個按鈕中，參考模擬結果可看「參考ＸＸ」活頁
先判斷年份，參考B3, B4選取值(B3可選擇2001年至2008年、B4為B1之至少三年期之年份)，若B3, B4為2008及2010，則保留2007, 2008, 2009, 2010之數據(即B3至B4之期間及B3減1之期間)，即L17到DQ17只要內容不包含2007, 2008, 2009, 2010，則18列以後為0，而包含2007, 2008, 2009, 2010之列則執行下述情況：

L到U列(以F18為1101為例)
L18：在FS活頁中，尋找ABC列分別為1101, C, 2001及1101, U, 2001之所在行數，取行數較前者，公式寫法可參考
=IF($E18="","",LOOKUP(9^9,MATCH(IF({1,0},$F18&"U"&L$17,$F18&"C"&L$17),INDIRECT("fs!A1:A40000")&INDIRECT("fs!B1:B40000")&INDIRECT("fs!C1:C40000"),)))
L19至U19以此類推，以下群組皆類似，基本上都是每十列換一種公式

V到AE列(以F18為1101為例)
V18：在FS活頁中，尋找A列為1101之Q列(行數為L18)與S列(行數為L18)之和，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$Q:$Q,L18)+INDEX(fs!$S:$S,L18),0)

AF到AO列(以F18為1101為例)
AF18：在FS活頁中，尋找A列為1101之R列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$R:$R,L18),0)

AP到AY列(以F18為1101為例)
AP18：在FS活頁中，尋找A列為1101之U列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$U:$U,L18),0)

BT到CC列(以F18為1101為例)
BT18：在FS活頁中，尋找A列為1101之Z列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$Z:$Z,L18),0)

CD到CM列(以F18為1101為例)
CD18：在FS活頁中，尋找A列為1101之AA列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$AA:$AA,L18),0)

CN到CW列(以F18為1101為例)
CN18：在FS活頁中，尋找A列為1101之Y列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$Y:$Y,L18),0)

CX到DG列(以F18為1101為例)
CX18：在FS活頁中，尋找A列為1101之I列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$I:$I,L18),0)

DH到DQ列(以F18為1101為例)
DH18：在FS活頁中，尋找A列為1101之K列(行數為L18)，若找不到請返回0，公式寫法可參考
=IFERROR(INDEX(fs!$K:$K,L18),0)

AZ到BI列(以F18為1101為例)
AZ18：在FS活頁中，尋找ABC列分別為1101, C, 2001之所在行數，其X列之值，公式寫法可參考
=IFERROR(INDEX(fs!$X:$X,MATCH($F18&"C"&L$17,INDIRECT("fs!A1:A40000")&INDIRECT("fs!B1:B40000")&INDIRECT("fs!C1:C40000"),)),0)

BJ到BS列(以F18為1101為例)
BJ18：在FS活頁中，尋找ABC列分別為1101, U, 2001之所在行數，其X列之值，公式寫法可參考
=IFERROR(INDEX(fs!$X:$X,MATCH($F18&"U"&L$17,INDIRECT("fs!A1:A40000")&INDIRECT("fs!B1:B40000")&INDIRECT("fs!C1:C40000"),)),0)

若還有不清楚，請再告知，謝謝各位老師協助！

ctp_119

都是政治家惹的祸，弄的我看繁体字很累！要是统一了，多好，就不至于这样辛苦了！

guojianlin1985

要是统一成繁体字你更辛苦。

piny

不好意思 我不會打簡体字 我也看不太懂簡体字

可否先行利用論壇右上角繁簡轉化來瞭解題意

謝謝老師關注 ^^

[ 本帖最后由 piny 于 2011-7-18 10:12 编辑 ]

蓝桥玄霜

我的想法是把这些公式都取消，直接用代码获得所需要的数据。
在我的这个附件中需要在fs表格中增加足够的数据，然后点击按钮。
试试看。

piny

無法正確運行，已重新上傳附件，可否在此附件上測試！

我的意思就是全部都以VBA運行，公式只是方便我這位VBA文盲測試用的，以及方便老師瞭解我想要的效果。

另由於代碼區若輸入簡体字，我這邊打開會全部亂碼，如下，故是否可修正後先行上傳代碼，俾小弟適時修改，謝謝！

Sub ndfx()
'爛僅煦昴
'0718 壺B3B4眕俋腔爛僅
Dim d, k, t, i&, x$, ks, js, n1%, nd, j&, Crr, Brr, y$, a, b, ii&, jj&
Set d = CreateObject("Scripting.Dictionary")
Arrfs = Sheet7.UsedRange
For i = 1 To UBound(Arrfs)
    If Arrfs(i, 1) <> "" Then
        x = Arrfs(i, 1) & Arrfs(i, 2) & Arrfs(i, 3)
        d(x) = i
    End If
Next
k = d.keys
t = d.items
ks = Val(Left([b3].Value, 4)) - 1
js = Val(Left([b4].Value, 4))
n1 = js - ks + 1
ReDim nd(1 To n1)
For i = 1 To n1
    nd(i) = i + ks - 1
Next
n = [f65536].End(xlUp).Row
Crr = Range("f18:f" & n)
ReDim Brr(1 To n - 17, 1 To 110)
i = 1
    For j = 1 To n1
        For ii = 1 To UBound(Crr)
            x = Crr(ii, 1) & "U" & nd(j)
            y = Crr(ii, 1) & "C" & nd(j)
            a = "": b = ""
            For jj = 0 To UBound(k)
                If x = k(jj) Then a = t(jj)
                If y = k(jj) Then b = t(jj)
                If a <> "" And b <> "" Then
                    If a < b Then Brr(ii, i + nd(j) - 2000 - 1) = a Else Brr(ii, i + nd(j) - 2000 - 1) = b 'L18  2001~2010
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 17) + Arrfs(Brr(ii, j), 19) 'Sales
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 18) 'COGS
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 21) 'OE
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(b, 24) '磁甜RD
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(a, 24) '等珨RD
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 26) '壽炵&#63509;种億
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 27) '壽炵&#63509;輛億
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 25) 'OP
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 9) 'FA
                    i = i + 10
                    Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 11) 'TA
                    i = i + 10
                    'Brr(ii, i + nd(j)-2000-1) = Arrfs(Brr(ii, j), 26)  'AFA
                    i = 1
                    Exit For
                End If
               
            Next
        Next
    Next
[l18].Resize(UBound(Brr), UBound(Brr, 2)).ClearContents
[l18].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub

piny

有哪位老師關注一下嗎？請以6樓附件測試，謝謝！^^

蓝桥玄霜

请见附件。
请测试。

piny

藍老師早安

還有幾點錯誤需請教

1.第25行和26行的後面都沒有數值？(可參考6F參考附件中相對應單元格)
2.V18至DQ26之數值幾乎皆不正確？(可參考6F參考附件中相對應單元格)
3.另請教執行有效性按鈕時，有發現以下代碼被文字表達，由於實際工作上凡執行有效性就得順便清空該區域，不知是否建議應如何改善？
    'Range("H2:K11").ClearContents

蓝桥玄霜

3，可去除 'Range("H2:K11").ClearContents前面的单引号'  ；
1，因为fs表在数据不足，没有1111   C   2010此类数据，所以这两行没有数值；
2，6F參考附件中相對應單元格里面没有数据，只有再对照你的公式看看，是不是栏目配对错了。