ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ÂǥѤé´Á§ïÅÜ­pºâ²£«~³Ñ¾l¼Æ¶q»P§¡»ù

[µo°Ý] ÂǥѤé´Á§ïÅÜ­pºâ²£«~³Ñ¾l¼Æ¶q»P§¡»ù

¤p§Ì¤~²¨¾Ç²L»Ý­n¤@­Ó¯àÂǥѤé´Á§ïÅÜ­pºâ²£«~³Ñ¾l¼Æ¶q»P§¡»ùªºexcel,½Ð¦U¦ì¤j¤jÀ°À°¦£
¦p¹Ï¤À§O¬°¸ê®Æ»P³Ì«áµe­±
³Ì«áµe­±ªº³¡¥÷¹ï©ó¤é´Á¬O¥i½Õ¾ãªº,¦p¤é´ÁÅÜ°Ê,«h³Ì«á¸ê®Æ©Ò§e²{ªºµe­±¤]·|§ïÅÜ
¬ÛÃöªºExcelÀɦbªþ¥ó¤¤,¦p¦³¤£²M·¡ªº½Ð¦A´£¥Xµo°Ý
­ì©l¸ê®Æ»P©Ò»Ý¸ê®Æ³£¦bªþ¥ó¸Ì

source.JPG (147.79 KB)

­ì©l¸ê®Æ

source.JPG

finalscreen.JPG (120.04 KB)

³Ì«áµe­±

finalscreen.JPG

test.rar (2.85 KB)

¥»©«³Ì«á¥Ñ register313 ©ó 2012-5-1 13:03 ½s¿è

¦^´_ 1# white5168

°Ñ¦Ò¥Î,»yªk¤£²z·Q,°õ¦æ³t«×ºC
¦Û°Êµ²ºâ¨ìÁʶR¤é´Á¤§³Ì«á¤@¤é
SOURCE¤u§@ªí·|³Q±Æ§Ç
  1. Sub AA()
  2. Dim Er(), Fr()
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d1 = CreateObject("scripting.dictionary")
  5. Set d2 = CreateObject("scripting.dictionary")
  6. Set d3 = CreateObject("scripting.dictionary")
  7. With Sheets("Source")
  8.   M = .[B2].End(xlDown).Row
  9.   .[A1].CurrentRegion.Sort Key1:=.[A2], Order1:=xlAscending, Header:=xlGuess
  10.   .[A1].CurrentRegion.Sort Key1:=.[B2], Order1:=xlAscending, Header:=xlGuess
  11.   Br = .Range("A2:E" & .[B2].End(xlDown).Row)
  12.   For i = 1 To UBound(Br)
  13.     x = Br(i, 2)
  14.     d(x) = d(x) + 1
  15.     If Not d1.exists(x) Then d1.Add x, Br(i, 4) Else d1(x) = d1(x) + Br(i, 4)
  16.     If Not d2.exists(x) Then d2.Add x, Br(i, 5) Else d2(x) = d2(x) + Br(i, 5)
  17.     If Not d3.exists(x) Then d3.Add x, Br(i, 3) * (Br(i, 5) - Br(i, 4)) Else d3(x) = d3(x) + Br(i, 3) * (Br(i, 5) - Br(i, 4))
  18.   Next i
  19. End With
  20. With Sheets("³Ì«á¸ê®Æ")
  21.   .[B1] = Application.Max(Sheets("Source").Columns("A"))
  22.   .[A3].CurrentRegion.Offset(1, 0) = ""
  23.   .[A4].Resize(d.Count, 1) = Application.Transpose(d.keys)
  24.   .[B4].Resize(d.Count, 1) = Application.Transpose(d1.Items)
  25.   .[C4].Resize(d.Count, 1) = Application.Transpose(d2.Items)
  26.   .[D4].Resize(d.Count, 1) = Application.Transpose(d3.Items)
  27.   For R = 4 To d.Count + 3
  28.     ReDim Preserve Er(4 To R)
  29.     ReDim Preserve Fr(4 To R)
  30.     If .Cells(R, "B") >= .Cells(R, "C") Then
  31.        Er(R) = .Cells(R, "B") - .Cells(R, "C")
  32.     Else
  33.        Fr(R) = .Cells(R, "B") - .Cells(R, "C")
  34.     End If
  35.   Next R
  36.   .[E4].Resize(R - 4, 1) = Application.Transpose(Er)
  37.   .[F4].Resize(R - 4, 1) = Application.Transpose(Fr)
  38.   For R = 4 To d.Count + 3
  39.     If .Cells(R, "E") > 0 Then
  40.        Max = Application.Match(.Cells(R, "A"), Sheets("Source").Range(Sheets("Source").[B1], Sheets("Source").[B1].End(xlDown)), 0) + d(.Cells(R, "A").Value) - 1
  41.        Min = Max - d(.Cells(R, "A").Value) + 1
  42.        Á`ÃB = 0: ³Ñ¾lÁ`¼Æ = 0
  43.        ³Ñ¾l¼Æ¶q = .Cells(R, "E")
  44.        For S = Max To Min Step -1
  45.          If ³Ñ¾l¼Æ¶q > Sheets("Source").Cells(S, "D") Then
  46.             Á`ÃB = Á`ÃB + Sheets("Source").Cells(S, "C") * Sheets("Source").Cells(S, "D")
  47.             ³Ñ¾l¼Æ¶q = ³Ñ¾l¼Æ¶q - Sheets("Source").Cells(S, "D")
  48.             ³Ñ¾lÁ`¼Æ1 = ³Ñ¾lÁ`¼Æ1 + Sheets("Source").Cells(S, "D")
  49.          Else
  50.             Á`ÃB = Á`ÃB + Sheets("Source").Cells(S, "C") * ³Ñ¾l¼Æ¶q
  51.             .Cells(R, "G") = Á`ÃB / .Cells(R, "E")
  52.             .Cells(R, "D") = .Cells(R, "D") + Á`ÃB * 2
  53.             GoTo 123
  54.          End If
  55.        Next S
  56.      End If
  57. 123:
  58.   Next R
  59.   For R = 4 To d.Count + 3
  60.     If .Cells(R, "F") < 0 Then
  61.        Max = Application.Match(.Cells(R, "A"), Sheets("Source").Range(Sheets("Source").[B1], Sheets("Source").[B1].End(xlDown)), 0) + d(.Cells(R, "A").Value) - 1
  62.        Min = Max - d(.Cells(R, "A").Value) + 1
  63.        Á`ÃB = 0: ³Ñ¾lÁ`¼Æ = 0
  64.        ³Ñ¾l¼Æ¶q = -.Cells(R, "F")
  65.        For S = Max To Min Step -1
  66.          If ³Ñ¾l¼Æ¶q > Sheets("Source").Cells(S, "E") Then
  67.             Á`ÃB = Á`ÃB + Sheets("Source").Cells(S, "C") * Sheets("Source").Cells(S, "E")
  68.             ³Ñ¾l¼Æ¶q = ³Ñ¾l¼Æ¶q - Sheets("Source").Cells(S, "E")
  69.             ³Ñ¾lÁ`¼Æ1 = ³Ñ¾lÁ`¼Æ1 + Sheets("Source").Cells(S, "E")
  70.          Else
  71.             Á`ÃB = Á`ÃB + Sheets("Source").Cells(S, "C") * ³Ñ¾l¼Æ¶q
  72.             .Cells(R, "H") = Á`ÃB / -.Cells(R, "F")
  73.             GoTo 456
  74.          End If
  75.        Next S
  76.      End If
  77. 456:
  78.   Next R
  79.   .Range("G4:H" & d.Count + 3).NumberFormatLocal = "0.00"
  80. End With
  81. MsgBox "µ²ºâ§¹²¦"
  82. End Sub
½Æ»s¥N½X
test.rar (14.91 KB)

TOP

½Ð°Ýregister313 ¤j¤j¯à±Nµ{¦¡½X¼Ò²Õ¤Æ¶Ü?
ÁÙ¦³¥Ø«e§ÚÁÙµLªk¤U¸ü±z©Ò´£¨ÑªºÀ£ÁYÀÉ,½Ð°Ý±z¶K¦bºô­¶¤Wªºµ{¦¡½X¬Oªþ¥ó¸Ìªº¤º®e¶Ü?

TOP

        ÀR«ä¦Û¦b : ®É®É¦n¤ß´N¬O®É®É¦n¤é¡C
ªð¦^¦Cªí ¤W¤@¥DÃD