- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
¦^´_ 3# adam2010
ÁÂÁ«e½ú¦^ÂÐ
½Ð«e½ú¥ý¸Õ¬Ý¬Ý
1.Âà¸m¤è¦¡¬O§_¾A¦X
2.Åu¥¤è¦¡¬O§_¾A¥Î
¤µ¤Ñ²ß±o ¸ê®ÆÂà¸m,Åu¥¤Ñ¼Æ
½m²ß°}¦C- Option Explicit
- Sub ¸ê®ÆÂà¸m()
- Dim Brr, Crr, c&, i&, j&, x&, xR, R, T, v, Y, Z, xA, Sc&, Sr&
- Dim B#, K%, P$, Q, Ra, Rs, Rn, n&, Avgd&, Avgv
- Set xA = ActiveSheet.Cells
- Set Y = CreateObject("Scripting.Dictionary")
- For Each Ra In xA.SpecialCells(2)
- R = Ra.Address
- Rn = IIf(Ra = "Á`p" And Rn = "" And Rs <> "", Ra.Address, Rn)
- Rs = IIf(Ra = "Á`p" And Rs = "", Ra.Address, Rs)
- Next
- Brr = xA.Range(Rs, Rn)
- Rs = Brr(1, 8)
- Rn = Brr(1, UBound(Brr, 2) - 1)
- Sc = Rn - Rs + 1 '¤Ñ¼Æ
- Sr = UBound(Brr) - 2 '«~¸¹¼Æ
- ReDim Crr(1 To Sc * Sr, 1 To 13)
- For j = 2 To Sr + 1
- For i = 1 To Sc
- n = n + 1
- Crr((j - 2) * Sc + i, 1) = n
- Crr((j - 2) * Sc + i, 2) = Rs + (i - 1)
- Crr((j - 2) * Sc + i, 13) = Brr(j, UBound(Brr, 2))
- For x = 1 To 7
- Crr(n, x + 2) = Brr(j, x)
- Next
-
- For x = 8 To UBound(Brr, 2) - 1
- If Brr(1, x) = Rs + (i - 1) Then
- Crr((j - 2) * Sc + i, 12) = Brr(j, x)
- End If
- Next
- Next
- Next
- For j = n To 1 Step -1
- If Crr(j, 12) > 0 Then
- For i = j - 1 To 1 Step -1
- If Crr(i, 12) > 0 Or Crr(i, 3) <> Crr(j, 3) Or i = 1 Then
- Avgd = j - i
- If Avgd > 0 Then
- Avgv = Crr(j, 12) / Avgd
- End If
- If Crr(1, 12) = "" And i = 1 Then
- Avgd = j - i + 1
- If Avgd > 0 Then
- Avgv = Crr(j, 12) / Avgd
- End If
- End If
- Exit For
- End If
- Next
- End If
- Crr(j, 10) = Avgd
- Crr(j, 11) = Avgv
- If j > 1 Then
- Avgd = IIf(Crr(j, 3) = Crr(j - 1, 3), Avgd, 0)
- Avgv = IIf(Crr(j, 3) = Crr(j - 1, 3), Avgv, 0)
- End If
- Next
- If Crr(1, 12) <> "" Then
- Crr(1, 10) = 1
- Crr(1, 11) = Crr(1, 12)
- End If
- Workbooks.Add
- [A1].Resize(1, 13) = Split("NO/¤é´Á/®Æ¸¹/¦T/ºU/¥i¥Î®w¦s/1300/" _
- & "¦b¨î¶q/Var/Åu¥¤Ñ¼Æ/Åu¥¼Æ¶q/q³æ¼Æ¶q/Á`p", "/")
- [A2].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
- Cells.Columns.AutoFit
- Cells.Rows.AutoFit
- Cells.Columns.AutoFit
- [2:2].Select
- ActiveWindow.FreezePanes = True
- [1:1].AutoFilter
- [A1].Select
- Cells.Borders.LineStyle = xlContinuous
- End Sub
½Æ»s¥N½X |
|