- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 254
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-11-23
              
|
19#
發表於 2012-5-1 17:07
| 只看該作者
回復 18# white5168
貼圖的資料並不是附件中CSV的資料
依照上述先進先出邏輯試著寫看看，你自己去比對看看結果正不正確
- Sub Get_Data()
- Dim Ar(), Ay(), x, y
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- Set d2 = CreateObject("Scripting.Dictionary")
- fs = ThisWorkbook.Path & "\DataBase.csv"
- Open fs For Input As #1
- Do Until EOF(1)
- Line Input #1, mystr
- a = Split(mystr, ",")
- If Val(a(0)) > 0 And Val(a(0)) <= [B1] Then
- If IsEmpty(d(a(1))) Then
- For i = 1 To Val(a(3))
- ReDim Preserve Ar(i)
- Ar(i - 1) = Val(a(2))
- Next
- If Val(a(3)) > 0 Then d(a(1)) = Ar
- Else
- Ar = d(a(1))
- s = UBound(Ar)
- For i = 1 To Val(a(3))
- ReDim Preserve Ar(s + i)
- Ar(s + i - 1) = Val(a(2))
- Next
- s = UBound(Ar)
- d(a(1)) = Ar
- End If
- If Val(a(4)) > 0 Then
- If IsEmpty(d1(a(1))) Then
- For i = 1 To Val(a(4))
- ReDim Preserve Ar(i)
- Ar(i - 1) = Val(a(2))
- Next
- If Val(a(4)) > 0 Then d1(a(1)) = Ar
- Else
- Ar = d1(a(1))
- s = UBound(Ar)
- For i = 1 To Val(a(4))
- ReDim Preserve Ar(s + i)
- Ar(s + i - 1) = Val(a(2))
- Next
- d1(a(1)) = Ar
- End If
- End If
- End If
- Erase Ay: Erase Ar
- Loop
- Close #1
- For Each ky In d1.keys
- If IsArray(d1(ky)) Then Ar = d1(ky): x = UBound(Ar) Else x = 0 '出貨
- If IsArray(d(ky)) Then Ay = d(ky): y = UBound(Ay) Else y = 0 '進貨
- If x = 0 And y > 0 Then '只進不出
- For i = 0 To y - 1
- 'sp = sp + Ar(i)
- bp = bp + Ay(i)
- Next
- bp = bp / y
- d2(ky) = Array(ky, y, 0, 0, Abs(y - x), y - x, Round(bp, 2), 0)
- bp = 0
- ElseIf y = 0 And x > 0 Then '只出不進
- For i = 0 To x - 1
- sp = sp + Ar(i)
- Next
- sp = sp / x
- d2(ky) = Array(ky, y, x, 0, 0, y - x, 0, Round(sp, 2))
- sp = 0
- ElseIf x > 0 And y > 0 Then
- If x > y Then '出大於進
- w = 0: w1 = y - x
- For i = 0 To y - 1
- pr = pr + Ar(i) - Ay(i)
- Next
- For j = i To x - 1
- nr = nr + Ar(i)
- Next
- nr = nr / (x - y) '不足量
- ElseIf x < y Then '進大於出
- w1 = 0: w = y - x
- For i = 0 To x - 1
- pr = pr + Ar(i) - Ay(i)
- Next
- For j = i To y - 1
- sr = sr + Ay(i)
- Next
- sr = sr / Abs(x - y) '不足量
- End If
-
- d2(ky) = Array(ky, y, x, pr, w, w1, Round(sr, 2), Round(nr, 2))
- pr = 0: nr = 0: sr = 0
- End If
- Erase Ay: Erase Ar
- Next
- [A4:H65536] = ""
- [A4].Resize(d2.Count, 8) = Application.Transpose(Application.Transpose(d2.items))
- End Sub
|
|
發表於 2012-4-29 07:20
| 
