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

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

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

¥»©«³Ì«á¥Ñ candy516 ©ó 2011-3-23 01:48 ½s¿è

¦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À°À°§Ú!ÁÂÁÂ!

³ø¹S²v.rar (300.4 KB)

¦^´_ 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

TOP

¦^´_ 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!

TOP

¥»©«³Ì«á¥Ñ Hsieh ©ó 2011-3-23 16:56 ½s¿è

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 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ªºÀ°¦£!

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

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

TOP

¦^´_ 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!

TOP

¦^´_ 7# GBKEE

ÁÂÁ«e½ú!^^

³ø¹S²v(test).rar (309.77 KB)

TOP

¦^´_ 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)
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

        ÀR«ä¦Û¦b : ¡i°µ¤Hªº¶}©l¡j¨C¤@¤Ñ³£¬O¬G¤Hªº¶}©l¡A¨C¤@­Ó®É¨è³£¬O¦Û¤vªºÄµ±§¡C
ªð¦^¦Cªí ¤W¤@¥DÃD