[µo°Ý] ¿z¿ï¸ê®Æ¨Ã¥B©ñ¨ì·sªºSheet¸Ì

candy516

¦U¦ì«e½ú§A­Ì¦n¡G
    §Ú¤S¦³¤@­Ó°ÝÃD·Q­n½Ð±Ð¤j®a¡A¬OÃö©ó¸ê®Æ¿z¿ïªº!§Ú¥»¨Ó·Q¥Î¤H¤u¤â°Êªº¤èªk¤@µ§¤@µ§¿z¿ï¡A¦ý§Úªº«ü¾É±Ð±Â¤@ª½¥s§Ú¼gµ{¦¡= = ¦ý§Ú¬O­Ó¶W¯Å¶W¯Å·s¤â¡A¤]¨S¦³¥¿¦¡¾Ç¹LVBA!Sheet1¬O¨CÀɪѲ¼ªº°£®§¤é¡ASheet2~11«h¬O¤Q¦~¶¡¨CªÑªº¤é³ø¹S²v¡C³Ì«á¤@­ÓSheet¬O§Ú·Q­nªºµ²ªG¡C±µ¤U¨Ó§Ú»Ý­n¿z¿ï¥X¨C¤@ÀɪѲ¼¦b°£®§¤é«á14¤Ñªº¤é³ø¹S²v(¥]§t°£®§¤é¦@15¤Ñ)¡CÁ|¦C¨Ó»¡¡A¦bSheet1¤¤2010ªº1234¶ÂªQ¥¦ªº°£®§¤é¬O20100719¡A«h¦bSheet2¤¤±N20100719~20100801¶ÂªQªº¤é³ø¹S²v§ì¦Ü¤@­Ó·sªºSheet¤¤(¥]§t¤é´Á¤]¤@°_§ì)¡C½Ð°Ý³o¼ËÁcº¾ªº¨BÆJ¡AVBA¥i¥H¿ì¨ì¶Ü?
§Æ±æ¦U¦ì¥i¥HÀ°À°§Ú!ÁÂÁÂ!

GBKEE

¦^´_ 1# candy516
¸Õ¸Õ¬Ý

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, °£®§¤é As Date, ªÑ²¼ As Range, R As Range, Ar(), i As Integer
   
4.     With Sheets("Sheet1")
   
5.         .Activate
   
6.         Set Rng = .Range("A2:A" & .Range("A2").End(xlDown).Row)  '³]©wSheet1ªÑ²¼½d³ò
   
7.         If Application.Intersect(Rng, ActiveCell) Is Nothing Then  '¨S¦³¿ï¾Ü¨ìªÑ²¼
   
8.             MsgBox "ªÑ²¼¥N¸¹: ¦³»~"
   
9.             Exit Sub
   
10.         End If
    
11.         Set Rng = ActiveCell
    
12.         'Rng(1, 2) = Rng.Cells(1, 2)
    
13.         °£®§¤é = Mid(Rng(1, 2), 1, 4) & "/" & Mid(Rng(1, 2), 5, 2) & "/" & Mid(Rng(1, 2), 7, 2)
    
14.     End With
    
15.     ReDim Ar(1, 0)
    
16.     With Sheets(Mid(Rng(1, 2), 1, 4))     '°£®§¦~«×¤u§@ªí
    
17.         Set ªÑ²¼ = .Rows(1).Find(Rng, LOOKAT:=xlPart, LookIn:=xlValues)  '§ä¨ìªÑ²¼¥N¸¹¦WºÙ ¤é³ø¹S²vÄæ¦ì
    
18.         For Each R In .Range("A3:A" & .Range("A3").End(xlDown).Row)     '
    
19.             If R >= °£®§¤é And R <= °£®§¤é + 14 Then
    
20.                 Ar(0, i) = R
    
21.                 Ar(1, i) = R.Cells(1, ªÑ²¼.Column)
    
22.                 i = i + 1
    
23.                 ReDim Preserve Ar(1, i)  '¼W¥[°}¦Cªººû¼Æ
    
24.             End If
    
25.         Next
    
26.     End With
    
27.     If i = 0 Then
    
28.         MsgBox "§ä¤£¨ì" & ªÑ²¼ & "¤é³ø¹S²v"
    
29.         Exit Sub
    
30.     End If
    
31.     With Sheets("Sheet2").Range("IV1").End(xlToLeft).Offset(, 1)  'Range("IV1")©¹¥ª¦³¸ê®Æªº²Ä¤@­ÓÀx¦s®æ->Offset(, 1) ¦V¥k²¾°Ê¤@Äæ
    
32.         .Cells(1, 2) = ªÑ²¼
    
33.         .Cells(2, 1) = "¦~¤ë¤é"
    
34.         .Cells(2, 2) = "¤é³ø¹S²v"
    
35.         .Cells(3, 1).Resize(i, 2) = Application.WorksheetFunction.Transpose(Ar)
    
36.     End With
    
37.     End
    
38. End Sub

½Æ»s¥N½X

candy516

¦^´_ 2# GBKEE


    ÁÂÁÂGBKEE «e½úÄ@·NÀ°§Ú¼g!^^¸Û¤ßªºÁÂÁÂÁ§A!
§Ú¸Õ¤F¤@¤UµLªk±N¥þ³¡µ²ªG¶]¥X¨Ó­C!
½Ð°Ý§ÚÀ³¸Ó±Nµ{¦¡½X¶K¦b­þ¤@­ÓSheet¤¤©O?
°õ¦æªº®É­Ô¦³¸õ¥X¤@­ÓMsgBox"ªÑ²¼¥N½X¦³»~"!
«ô°U±z¤F!

Hsieh

¦^´_ 3# candy516

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. If Not C Is Nothing Then
    
18.    Set B = .Rows(1).Find(Split(ky, ",")(0))
    
19.    Set B1 = .[A1:A2]
    
20.    Set B2 = B.Resize(2, 1)
    
21.    Set Rng = C.Resize(15, 1)
    
22.    Set Rng1 = .Cells(C.Row, B.Column).Resize(15, 1)
    
23.    With sht
    
24.       B1.Copy .Cells(r, k)
    
25.       B2.Copy .Cells(r, k + 1)
    
26.       Rng.Copy .Cells(r + 2, k)
    
27.       Rng1.Copy .Cells(r + 2, k + 1)
    
28.    End With
    
29.    k = IIf(k = 255, 1, k + 2)
    
30.    r = IIf(k = 1, r + 18, r)
    
31.    Else
    
32.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
33. End If
    
34. End With
    
35. Next
    
36. Application.ScreenUpdating = True
    
37. End Sub

½Æ»s¥N½X

candy516

¦^´_ 4# Hsieh


ÁÂÁÂHsieh «e½ú!
¦A¶]¥X¨Óªºµ²ªG¸Ì¡A²Ä¤@µ§¸ê®Æ¬O¶ÂªQ¬O20100719~20100629¡A¦ý§Ú·Q­nªºµ²ªG¬O20100719~20100806~
½Ð°Ý§Ú³o¼Ë»Ý­n§ï­þ¤@­Ó¦a¤è?§Ú¦³¸ÕµÛ§ó§ï¡A¦ýµLªk¶]¥X¨Ó¡C¥t¥~¦b½Ð±Ð¤@¤U¡A¦pªG§Ú±µ¤Uªº¸ê®Æ§ó§ï¡A¹³¬O§â³ø¹S²v´«¦¨¨CªÑ¬Õ¾l¡A
¦Ó§Ú¦P¼Ë¬O­n¥Îµ{¦¡§ì¥X°£®§¤é«á14¤Ñ±o¸ê®Æ¡A¬O§_§âµ{¦¡½X¶K¤W§Y¥i!(¸ê®Æ®æ¦¡¤@¼Ë)
·PÁ±zªºÀ°¦£!

Hsieh

¦^´_ 5# candy516
¤é´Á¶¶§Ç¬Ý¿ù¡A­n©¹¤W15¤Ñ¤~¹ï
¶¶«K±NµL¸ê®Æ±ø¥ó§ï¤@¤U

1. Sub ex()
   
2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set sht = Sheets.Add(after:=Sheets(1))
   
5. Application.ScreenUpdating = False
   
6. With Sheet1
   
7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
   
8.       mystr = A & "," & Left(A.Offset(, 1), 4)
   
9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
   
10.    Next
    
11. End With
    
12. k = 1: r = 1
    
13. For Each ky In d.keys
    
14. y = Split(ky, ",")(1)
    
15. With Sheets(y)
    
16. Set C = .Columns("A").Find(d(ky))
    
17. Set B = .Rows(1).Find(Split(ky, ",")(0))
    
18. If Not C Is Nothing And Not B Is Nothing Then
    
19. x = Application.Max(3, C.Row - 14)
    
20.    Set B1 = .[A1:A2]
    
21.    Set B2 = B.Resize(2, 1)
    
22.    Set Rng = .Cells(x, 1).Resize(15, 1)
    
23.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
    
24.    With sht
    
25.       B1.Copy .Cells(r, k)
    
26.       B2.Copy .Cells(r, k + 1)
    
27.       Rng.Copy .Cells(r + 2, k)
    
28.       Rng1.Copy .Cells(r + 2, k + 1)
    
29.    End With
    
30.    k = IIf(k = 255, 1, k + 2)
    
31.    r = IIf(k = 1, r + 18, r)
    
32.    Else
    
33.    MsgBox "µL¦¹°£Åv¸ê®Æ"
    
34. End If
    
35. End With
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 3# candy516
¶ÇÀɨӬݬÝ

candy516

¦^´_ 6# Hsieh


  ½Ð°ÝHsieh «e½ú~
³o¨â¦¸ªºµ{¦¡½X®t§O³Ì¥D­n¬O"x = Application.Max(3, C.Row - 14)"¶Ü?¥Nªí·N«ä¬O?!
¦pªG§Ú­n§ï§ì°£®§¤é«á30¤éªº³ø¹S¬O¤£¬O±N³¡¤Àµ{¦¡½X§ï±¼§Y¥i?!
If Not C Is Nothing And Not B Is Nothing Then
x = Application.Max(3, C.Row - 14)
   Set B1 = .[A1:A2]
   Set B2 = B.Resize(2, 1)
   Set Rng = .Cells(x, 1).Resize(30, 1)
   Set Rng1 = .Cells(x, B.Column).Resize(30, 1)
   With sht
      B1.Copy .Cells(r, k)
      B2.Copy .Cells(r, k + 1)
      Rng.Copy .Cells(r + 2, k)
      Rng1.Copy .Cells(r + 2, k + 1)
   End With
   k = IIf(k = 255, 1, k + 2)
   r = IIf(k = 1, r + 33, r)
   Else
   MsgBox "µL¦¹°£Åv¸ê®Æ"

ÁÂÁ±z!

candy516

¦^´_ 7# GBKEE

ÁÂÁ«e½ú!^^

Hsieh

¦^´_ 8# candy516


    x = Application.Max(3, C.Row - 14)
¬O¦]¬°­nºâ§ä¨ì¤é´Áªº¦ì¸m©¹¤W14®æªº¦C¸¹
­Y©¹¤W14®æªº¦C¸¹¥u¦³<=3´N­n¥H3§@¬°¶}©l§ì¸ê®Æªº¦C¦ì
©Ò¥H­Y§A­n§ì30¤Ñ¸ê®Æ³oÃä¤]­n§ï
x = Application.Max(3, C.Row - 29)