- ©«¤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
|
¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-10-24 13:37 ½s¿è
¦^´_ 16# jomeow
ÁÂÁ¤W½×¾Â¤@°_¾Ç²ß
Option Explicit
Sub TEST_1()
Dim Brr, Crr, v&, i&, R&, K&, M&, j%, Q%, c%, A%, Ss As Worksheet, Sa As Worksheet
'¡ô«Å§iÅܼÆ:(Brr, Crr)¬O³q¥Î«¬ÅܼÆ,(v,i,R,K,M)¬Oªø¾ã¼Æ,(j,Q,c,A)¬Oµu¾ã¼Æ
'(Ss,Sa)¬O¤u§@ªíÅܼÆ
Set Ss = Sheets("data input"): Set Sa = Sheets("calculation")
'¡ô¥OSs³o¤u§@ªíÅܼƸ˲± ¤u§@ªí "data input"
'¡ô¥OSa³o¤u§@ªíÅܼƸ˲± ¤u§@ªí "calculation"
K = 2000: Brr = Range(Ss.[A1], Ss.UsedRange.Offset(1, 0))
'¡ô¥OK³oªø¾ã¼ÆÅܼƬO±`¼Æ2000
'¡ô¥OBrr³o³q¥Î«¬ÅܼƬO¤Gºû°}¦C,¥HSsÅܼƪº[A1]¨ì¤w¨Ï¥ÎÀx¦s®æ¤U°¾²¾¤@¦C,
'³o½d³òÀx¦s®æȱa¤JBrr°}¦C¤¤
ReDim Crr(1 To UBound(Brr), 1 To UBound(Brr, 2))
'¡ô«Å§i³oCrr³q¥Î«¬ÅܼƬO¤GºûªÅ°}¦C:
'°}¦C¤W¤U½d³ò±q¯Á¤Þ¸¹1¨ìBrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹
'°}¦C¥ª¥k½d³ò±q¯Á¤Þ¸¹1¨ìBrr°}¦C¾î¦V³Ì¤j¯Á¤ÞÄ渹
For j = 2 To UBound(Brr, 2)
'¡ô³]¶¶°j°éj:±q2¨ì Brr°}¦C¾î¦V³Ì¤j¯Á¤ÞÄ渹
c = c + 1: R = 0: Q = 0
'¡ô¥Oc³oµu¾ã¼ÆÅܼƲ֥[1
'¡ô¥OR³oªø¾ã¼ÆÂk¹s,¥OQ³oªø¾ã¼Æ¤]Âk¹s
If Brr(2, j) Like "BM *" = False Then Exit For
'¡ô¦pªG²Ä2¦Cj°j°éÄæBrr°}¦CȤ£¬O¥H BM ¦r¦ê¶}ÀY!´Nµ²§ôjªº°j°é
If Brr(3, j) = "" Then GoTo j01
'¡ô¦pªG²Ä3¦Cj°j°éÄæBrr°}¦CȬOªÅ¦r¤¸!´N¸õ¨ì¼Ð¥Ü j01¦ì¸mÄ~Äò°õ¦æ
For i = 3 To UBound(Brr)
'¡ô³]¶¶°j°éi:±q3¨ì Brr°}¦Cºî¦V³Ì¤j¯Á¤Þ¦C¸¹
v = v + Val(Brr(i, j)): A = A + 1
'¡ô¥Ov³oªø¾ã¼ÆÅܼƲ֥[(i°j°é¦C/j°j°éÄæBrr°}¦CÈ)Âà¤Æªº¼ÆÈ
If Trim(Brr(i + 1, j)) = "" Then Q = 1
'¡ô¦pªG¤U¤@Ó°j°é°}¦CȬO ªÅ¦r¤¸!´N¥OQÅܼƬO1
If (v = K And A > 1) + (v > K) + (Q = 1 And v > 0) < 0 Then
'¡ô¦pªG(vÅܼƬOè¦n2000,¦Ó¥B¬O²Ö¥[¤~è¦n¬O2000ªº),©Î
'vÅܼƤj©ó 2000,©Îv¤j©ó0 ¥B¤w¸g¬O¸ÓÄæ³Ì«á¤@Ó¼ÆÈ,
'¦pªG¥H¤W¤TºØ±ø¥óªº¨ä¤¤¤@ºØ±ø¥ó¦¨¥ß!
R = R + 1: Crr(R, c) = v: v = 0: A = 0
'¡ô¥ORÅܼƲ֥[1
'¡ô¥ORÅܼƦCcÅܼÆÄæCrr°}¦CȬOvÅܼÆ
'¡ô¥OvÅܼÆÂk¹s,AÅܼƤ]Âk¹s
End If
If Q = 1 Then Exit For
'¡ô¦pªGQÅܼƬO1!´Nµ²§ôi°j°é
Next
If M < R Then M = R
'¡ô¦pªGMÅܼƤp©óRÅܼÆ!´N¥OMÅÜ¼Æ µ¥©óRÅܼÆ
j01: Next
If M = 0 Then Exit Sub
'¡ô¦pªGMÅܼƬO0!´Nµ²§ôµ{¦¡°õ¦æ
Sa.[B22:F30].ClearContents
'¡ô¥OSaÅܼƪº[B22:F30]Àx¦s®æ²M°£¤º®e
Sa.[B22].Resize(M, c - 1) = Crr
'¡ô¥OSaÅܼƪº[B22]¦V¤UÂX®iMÅܼƦC,¦V¥kÂX®i(c-1)Äæ,
'³o½d³òÀx¦s®æȬOCrr°}¦CÈ
Erase Brr, Crr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub |
|