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

[µo°Ý] ¦Û°Ê¾ã²z¸ê®Æ

[µo°Ý] ¦Û°Ê¾ã²z¸ê®Æ

¦U¦ì°ª¤â¨ó§U¡A§Ú¦b¨C¤é±Æµ{¤§«á»Ý­n±N±Æ¦nªº¸ê®Æ¨Ì¾Ú¾÷¥x§O©ñ¤J¶×Á`ªí¤º
½Ð°Ý­n±q¾ï¦â°Ï¶ô¾ã²z¨ì¶×Á`¤u§@ªíªº¥¨¶°­n¦p¦ó»s§@
¦]¬°¾÷¥x¸¹½X»P¾÷¥x¼Æ³£·|ÅÜ°Ê¡A¨C­Ó¯¸ÂI¾÷¥x¼Æ³Ì¦h5¥x
¥Ø«e³£¬O±Æ¦n«á¤â°Ê½Æ»sÂà­È¨ìÁ`ªí¡÷±Æ§Ç¡÷§R°£ªÅ®æ¡A
¦]¬°¨ä¹ê¯¸ÂI¤£¥u4­Ó©Ò¥H±Æ¦n¤§«áÁٻݭn®ö¶OÆZ¦h®É¶¡¾ã²zªº


¾ã²z°ÝÃD.zip (66.17 KB)
Adam

¦^´_ 1# adam2010
¸Õ¸Õ¬Ý
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D As Object, Sh As Worksheet, Rng As Range, i As Integer, AR As Variant
  4.     Set D = CreateObject("SCRIPTING.DICTIONARY")          '¦r¨åª«¥ó
  5.     For Each Sh In Sheets                                 '¤u§@ªíª«¥ó¶°¦X
  6.         If Not Sh.Name Like "·JÁ`*" Then                  '¤ñ¹ï¤u§@ªí¦WºÙ
  7.             Set Rng = Sh.[U1]                             '¾÷¥x©T©w±q[U1]¶}©l
  8.             Do While Rng <> ""
  9.                 For i = 2 To Sh.[A1].End(xlDown).Row      '[A1]©¹¤U¨ì³Ì«á³sÄòªº¸ê®Æ¦C¸¹
  10.                     If Rng.Cells(i, 1).Value <> "" Then
  11.                         If Not D.EXISTS(Rng.Value) Then   'EXISTS: ¶Ç¦^¦r¨åª«¥ó(key[ÃöÁä¦r])¦s¦b=True
  12.                             D(Rng.Value) = Array(Rng.Cells(i, 1).Value) '¦r¨åª«¥ó(key).Item=>¤º®e,¸m¤J°}¦C
  13.                         Else
  14.                             AR = D(Rng.Value)                           '°}¦C¨ú±o¦r¨åª«¥ó(key).Item
  15.                             ReDim Preserve AR(UBound(AR) + 1)           '°}¦CÂX¥R¼W¥[¤@¤¸¯À)
  16.                              AR(UBound(AR)) = Rng.Cells(i, 1).Value     '°}¦C(UBound(AR))¤¸¯Àªº¤W­­­È
  17.                              D(Rng.Value) = AR                          '¦r¨åª«¥ó(key[ÃöÁä¦r])=°}¦C
  18.                         End If
  19.                     
  20.                     End If
  21.                 Next
  22.                 Set Rng = Rng.Offset(, 1)                   '¦V¥k²¾°Ê
  23.             Loop
  24.         End If
  25.     Next
  26.     With Sheets("·JÁ`")
  27.         .UsedRange.Clear
  28.         i = 1
  29.         For Each AR In D.KEYS             '¦r¨åª«¥ó(key)
  30.             .Cells(1, i) = AR
  31.             .Cells(2, i).Resize(UBound(D(AR)) + 1) = Application.WorksheetFunction.Transpose(D(AR)) '¤@ºû°}¦CÂন¤Gºû°}¦C
  32.             i = i + 1
  33.        Next
  34.         .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:= _
  35.         xlYes, OrderCustom:=1, Orientation:=xlLeftToRight   '±Æ§Ç´`¦C(¾î¦V)
  36.      End With
  37. End Sub
½Æ»s¥N½X
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

·PÁÂGBKEEªº¨ó§U¡A²Ä¤@¦¸¬Ý¨ì¨Ï¥Î Option Explicit¡A¬d¤F¤@¤U¬O¦b¼Ò²Õ¼h¦¸¤¤¨Ï¥Î¡A±j¨î¼Ò²Õ¤¤ªº©Ò¦³Åܼƥ²¶·©ú½T¦a«Å§i¡A¬Ý¤£¤ÓÀ´¦ý¬O´ú¸ÕOK!
¯u¬O¤Ó±j¤F¡A©Ò¥H§Ú¥u­n½T«O¨C­Ó¯¸ÂI¤u§@ªíªº¾÷¥x¸ê®Æ³£±qU1¶}©l¡A¤£ºÞ´X¯¸¥u­n¤£¥s·JÁ`¡A
´N³£¥i¥H¾ã²z¶i·JÁ`¸Ì­±¥hÅo~
¯u¬O¤Ó·PÁ¤F¡I
Adam

TOP

¥»©«³Ì«á¥Ñ GBKEE ©ó 2014-1-19 16:15 ½s¿è

¦^´_ 3# adam2010

§Ú§¹¾ãªºµ{¦¡½X¤j³£·|¥[¤W   Option Explicit ¤£À´¬Ý¬Ý³o¸Ì
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P±Æ§Ç,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr, Y, Z, R&, C&, i&, j&, T$
Dim xR As Range, Sh As Worksheet
ReDim Crr(1 To 1000, 1 To Columns.Count - 1)
For Each Sh In Sheets
   If InStr(Sh.Name, "¯¸") = 1 Then
      Set xR = Intersect(Sh.UsedRange, Sh.[U:Y]): Brr = xR
      For C = 1 To UBound(Brr, 2)
         If Brr(1, C) = "" Then GoTo i01 Else: j = j + 1: i = 0
         For R = 1 To UBound(Brr)
            T = Brr(R, C)
            If R = 1 Then T = Left(T, 3) & Format(Mid(T, 4), "00")
            If T <> "" Then i = i + 1: Crr(i, j) = T
         Next
         If i > Z Then Z = i
i01:  Next
   End If
Next
With Sheets("·JÁ`").[A1].Resize(Z, j)
   .CurrentRegion.Clear
   .Value = Crr
   .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=2
   For C = 1 To j
      Intersect(.Cells, .Item(C).EntireColumn).Sort _
      Key1:=.Item(C), Order1:=1, Header:=1, Orientation:=1
   Next
End With
Set Sh = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : «Î¼e¤£¦p¤ß¼e¡C
ªð¦^¦Cªí ¤W¤@¥DÃD