無法正確運行,已重新上傳附件,可否在此附件上測試!
我的意思就是全部都以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) '壽炵种億
i = i + 10
Brr(ii, i + nd(j) - 2000 - 1) = Arrfs(Brr(ii, j), 27) '壽炵輛億
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 |