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

Ãö©ó¼g¥¨¶°µ{¦¡¦Û°Ê¿z¿ï§PÂ_°Ïªº¥N½X½Æ»s¦¨¸Ó¥N½X³æ¿W¬¡­¶Ã¯

¦^´_ 10# ¾Ç¨ì¦Ñ¦º
¦^´_ 9# yen956
¬°°t¦X¹ê°È¤Wªº¹ê»ÚÀ³¥Î¡A±N¥¦¾ã²z¤F¤@¤U¡A
¨Ã¤Þ¥Î¤@¨Ç¥i¯à¦]¯À¡A¥H¤Î¨B§½¦Ò¶q¡B¦Ó°µ
¥Xªº½d¨Ò¡A´£¨Ñ°Ñ¦Ò¬Ý¬Ý¡I
  1. '  ½Ð¶K¨ì "·JÁ`ªí"
  2. Sub ·J¤JÁ`ªí()
  3.     Dim sh1 As Worksheet, sh2 As Worksheet
  4.     Dim Lst1 As Integer
  5.     Dim J As Integer
  6.     Dim msg As Boolean
  7.    
  8.     Set sh1 = Sheets("·JÁ`ªí")
  9.     sh1.Cells.Clear
  10.     msg = False
  11.    
  12.     For J = 1 To Sheets.Count
  13.         If Sheets(J).Name <> "·JÁ`ªí" Then
  14.             Set sh2 = Sheets(J)
  15.             Lst1 = IIf(sh1.[B65536].End(xlUp).Row = 1, 1, sh1.[B65536].End(xlUp).Row + 1)
  16.            '  sh2.UsedRange.Address = "$B$4:$E$7" : String
  17.            '  sh2.UsedRange.Offset(1, 0).Address = "$B$5:$E$8" : String
  18.            '  ²Ä¤@¦¸»Ý¥ý³s¦P¼ÐÃD¤Î¨ä¤º®e¤@¨Ö·J¤J¨ìÁ`ªí¤º¡A¤§«á¶È½Æ»s¨C¤@¤u§@ªí³æ¤§¤º®e (¤£§t¼ÐÃD¦b¤º)¡C
  19.            sh2.UsedRange.Offset(IIf(msg, 1, 0), 0).Copy sh1.Cells(Lst1, 2)
  20.            msg = True
  21.         End If
  22.     Next
  23. End Sub

  24. '  ·J¥X¨ì¤À­¶
  25. '  À³¥Î½d³ò¡G «Ø¥ß¦r¨å¡B¤j¤p±Æ§Ç¡B¶K»s½Æ»s¤º®e¡B¦p¦óÀˬd¤u§@ªí³æ¤w§_¦s¦b¡B°ÊºA²£¥Í¤u§@ªí³æ¡B
  26. '             ²M°£¼È¦s¤u§@°Ï¶ô¡B¥H¤Î¦r¨åªº¹ê°ÈÀ³¥Î»P§Þ¥©¡C
  27. Sub ·J¥X¨ì¤À­¶()
  28.     Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, dic As Object
  29.     Dim Lst1 As Integer, v As Variant
  30.     Dim J As Integer, I As Integer
  31.    
  32.     Set dic = CreateObject("scripting.dictionary")
  33.     Set sh1 = Sheets("·JÁ`ªí")
  34.     Lst1 = sh1.[B65536].End(xlUp).Row
  35.    
  36.     sh1.Range("B1:E" & Lst1).Copy sh1.[W1]     '  ¥tÅP¾Ô³õ (B Äæ¥ý«ö·Ó¦r¥À¤j¤p±Æ§Ç«á¦A¦æ·J¥X¨ì¦U¬ÛÃö¤u§@ªí³æ)
  37.     With [W2].Resize(Lst1 - 1, 4)
  38.         .Cells.Sort Key1:=.Cells(1), Key2:=.Cells(3), Order1:=xlAscending, Header:=xlNo    '  xlDescending
  39.     End With
  40.    
  41.     For J = 2 To Lst1
  42.         dic(sh1.Range("W" & J).Text) = dic(sh1.Range("W" & J).Text) + 1
  43.     Next J
  44.    
  45.     Set rng = Sheets("·JÁ`ªí").[W2]
  46.     For Each v In dic.KEYS            '   v = "A" : Variant/String
  47.         I = dic.Item(v)               '   I = 3 : Integer
  48.         J = checkShts(CStr(v))
  49.         
  50.         If J > 0 Then
  51.             Set sh2 = Sheets(J)
  52.         Else
  53.             Set sh2 = Sheets.Add(After:=Sheets(Sheets.Count))
  54.             sh2.Name = v
  55.         End If
  56.         
  57.         With sh2
  58.             .Cells.Clear
  59.             sh1.[W1:Z1].Copy .[B1]
  60.             rng.Resize(I, 4).Copy .[B2]
  61.             Set rng = rng.Offset(I)       '  Rng.Address = "$B$5" : Rng.Address = "$B$7" : String
  62.         End With                          '  Rng.Address = "$B$8" : String
  63.     Next
  64.     sh1.[W:Z].Clear                       '  ²M°£¥tÅP¤§¾Ô³õ (W ¦Ü Z Ä涡¤º®e)
  65. End Sub

  66. Function checkShts(vSht As String) As Integer
  67.     Dim flg As Integer
  68.    
  69.     For flg = 1 To Sheets.Count
  70.         If Sheets(flg).Name = vSht Then checkShts = flg: Exit Function
  71.     Next flg
  72.     checkShts = 0
  73. End Function
½Æ»s¥N½X

TOP

'­É¥Î c¤j ªº·§©À, ·s¼W¤À­¶, ³o¼Ë¸û¦³¼u©Ê
'½Ð¶K¨ì "·JÁ`ªí"
'·J¥X¨ì¤À­¶3
'§P§P¤À­¶¬O§_¦s¦b
Function shExist(ByVal shName As String) As Boolean
    Dim I As Integer
    shExist = False
    For I = 1 To Sheets.Count
        If Sheets(I).Name = shName Then
            shExist = True
            Exit Function
        End If
    Next
End Function

Sub ·J¥X¨ì¤À­¶3()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shNameCnt As Integer
    Dim I As Integer, J As Integer
   
    '********************
    '²M°£¤À­¶¤º®e, ¦p¦³¨ä¥L­«­n¤À­¶, ¦p"²Î­p"µ¥, ¨â¦C*****¶¡, ½Ðµù¸Ñ±¼©Î§R±¼
    For J = 1 To Sheets.Count
        If Sheets(J).Name <> "·JÁ`ªí" Then Sheets(J).Cells.Clear
    Next
    '**************
   
    '¥[¤J­ì§Ç¸¹, ¤è«K«ì´_­ìª¬(¼È©ñÄæA,¥i§ï©ñ§OÄæ)
    Lst1 = [B65536].End(xlUp).Row
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '«ö¤u§@ªí¦WºÙ±Æ§Ç
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    For I = 5 To Lst1
        shName = Cells(I, 2)
        
        '§P§P¤À­¶¬O§_¦s¦b, ¦p¤£¦s¦b«h·s¼W¤@­¶
        If Not shExist(shName) Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        [C4:E4].Copy Sheets(shName).[C4]     '½Æ»s¼ÐÃD
        [C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])"   '­pºâ¦P¦Wªº¤u§@ªí¦³´X­Ó
        Cells(I, 2).Resize([C3], 4).Copy Sheets(shName).[B5]         '§å¦¸½Æ»s
        I = I + [C3] - 1
    Next
   
    '«ì´_­ìª¬, «ö­ì§Ç¸¹±Æ§Ç, ¨Ã²M°£¼È¦s°Ï
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear: [C3].Clear    'ÄæA ¤Î [C3] §¡¬°¼È¦s°Ï
End Sub

TOP

¿z¿ïªk¡I¡I¡I

Sub Macro1()
Dim xArea As Range, i&, T$, TT$, Sht As Worksheet
Set xArea = Range([B4], Cells(Rows.Count, "B").End(xlUp)(1, 4))
For i = 2 To xArea.Rows.Count
¡@¡@T = xArea(i, 1): Set Sht = Nothing
¡@¡@If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
¡@¡@On Error Resume Next:   Set Sht = Sheets(T):  On Error GoTo 0
¡@¡@If Sht Is Nothing Then Set Sht = Sheets.Add(After:=Sheets(Sheets.Count))
¡@¡@Sht.Name = T: Sht.UsedRange.Clear
¡@¡@With xArea
¡@¡@¡@¡@.Parent.Select
¡@¡@¡@¡@.AutoFilter Field:=1, Criteria1:=T
¡@¡@¡@¡@.Copy Sht.[B4]
¡@¡@End With
¡@¡@TT = TT & "/" & T
101: Next i
ActiveSheet.AutoFilterMode = False
End Sub

TOP

¦^´_ 13# ­ã´£³¡ªL
­ã¤j§A¦n!!
¤S¾Ç¨ì¤@©Û, ª½±µ
    Set Sht = Nothing
    If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
    On Error Resume Next
    Set Sht = Sheets(T)
    On Error GoTo 0
    If Sht Is Nothing Then
        Set Sht = Sheets.Add(After:=Sheets(Sheets.Count))
    End If
´N¥i¥H¤£¥²¥ý§PÂ_sht¬O§_¦s¦b,¯u°ª, ¦¬¤U, ÁÂÁÂ!!
¦ý½Ð°Ý InStr(TT & "/", "/" & T & "/")  ªº§@¥Î¬O¤°»ò?ÁÂÁÂ!!

TOP

¦^´_ 14# yen956


    §Ú·QInStr(TT & "/", "/" & T & "/")ªº·N«ä¬°
·í²Ä¤@¦¸Åª¨ú¹Lªº¤u§@ªí¦WºÙ·|¼g¤J¨ìÅܼÆTTªº¦r¦ê¤¤¡A¦]¬°¤w¸g°µ¹L¿z¿ï¤F¡A©Ò¥H·í¦A¦¸Åª¨ú¨ì´¿°O¿ý¹Lªº¦WºÙ®É¸õ¹L
¦Ó"/"«h¬O­n°Ï¤À¦U¤u§@ªí¦Wªº°Ï¹j¡A¤£·|­«ÂСAÅýInStr®e©ö§PÂ_¡A¦Ó¤£·|²£¥Í¿ù»~ªº§PÂ_

TOP

¥»©«³Ì«á¥Ñ ­ã´£³¡ªL ©ó 2016-2-22 12:06 ½s¿è

¦^´_ 15# lpk187


§¹¥þ¥¿½T, ÁÂÁ¤j¥X¤O¸ÑÄÀ!

InStr(TT & "/", "/" & T & "/")¡@¥Î"/'¤À¹j¡A¥i¥H²M·¡¤À§O A AA AAA ©Î¡@A1 A11 A111¡A¦Ó¤£·|»~§P¡I¡I
¦Ó¥B²z½×¤W¡A¤u§@ªí¦WºÙ¤£·|¦³"/"¦r¤¸¡A­Y¥Î¨ä¥¦²Å¸¹¡A´N­n¦Ò¼{¤u§@ªíªí¦WºÙ¬O§_§t¦³³o­Ó²Å¸¹¡A
¨Ò¦p¡G¥Î"-"¤À¹j¡A´N¥i¯à¹ï 1-1   1-11   1-111  ¬Û¦ü¤u§@ªí»~§P¡I¡I

TOP

¦^´_ 16# ­ã´£³¡ªL
¦^´_ lpk187:
¦^´_ ­ã¤j:
ÁÂÁ¨â¦ì¸Ô²Óªº»¡©ú, ÁÂÁÂ!!

TOP

'·J¥X¨ì¤À­¶4(¯Â¦Û§Ú¾Ç²ß VBA ¥Î, §OµL¥¦·N):
'§ó·sª©, §ó·s­«ÂI¦p¤U:
'1. ¬JµM ÄæA¤Î[C3] §¡¬°¼È¦s°Ï, «hÀ³¾ã¦X¨ì¦P¤@Ä椤, ¬G[C3]À³§ï¨ì[A3]
'2. ¨â¦C*****¶¡ªº ²M°£¤À­¶ À³²¾ "¥Dµ{¦¡" ¦¡¤º, ¥iÁקK»~§R­«­n¸ê®Æ
'3. §ï¥Î­ã¤jªº·§©À, ¤£¥t§P§O¤À­¶¬O§_¦s¦b, §Y§R°£ Function shExist, ¥i¬Ù±¼¤£¤Ö°j°é
'
'§ó¥¿µ²ªG¦p¤U:
'½Ð¶K¨ì "·JÁ`ªí"

Sub ·J¥X¨ì¤À­¶4()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shName As String
    Dim i As Integer, J As Integer
    Lst1 = [B65536].End(xlUp).Row
   
    '¥[¤J­ì§Ç¸¹, ¤è«K«ì´_­ìª¬(¼È©ñÄæA,¥i§ï©ñ§OÄæ)
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '«ö¤u§@ªí¦WºÙ±Æ§Ç
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    '¥Dµ{¦¡
    For i = 5 To Lst1
        shName = Cells(i, 2)
        
        Set sh1 = Nothing
        On Error Resume Next
        Set sh1 = Sheets(shName)
        On Error GoTo 0
        
        '­Y sh1 ¤´¬° Nothing ¡÷ ¦W¬° shName ªº¤u§@ªí¨Ã¤£¦s¦b ¡÷ ¼W¥[·s¤u§@ªí
        If sh1 Is Nothing Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        sh1.Cells.Clear           '²M°£¤À­¶
        [B4:E4].Copy sh1.[B4]     '½Æ»s¼ÐÃD
        [A3].FormulaR1C1 = "=COUNTIF(C[1],""=""&R" & i & "C[1])"   '­pºâ¦P¦Wªº¤u§@ªí¦³´X­Ó
        Cells(i, 2).Resize([A3], 4).Copy sh1.[B5]                  '§å¦¸½Æ»s¦P¦Wªº¤u§@ªí
        i = i + [A3] - 1                '¸õ¨ì¤U­Ó¤£¦P¦W¤u§@ªí, ¬G¤£¥Î¿z¿ï
    Next
   
    '«ì´_­ìª¬ ¡÷ «ö­ì§Ç¸¹±Æ, ¨Ã²M°£¼È¦s°Ï
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear     '²M°£¼È¦s°Ï ÄæA
End Sub

TOP

  1. Sub ex()
  2. Dim ar(0 To 1), ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("·JÁ`ªí")
  5. For Each a In .Range(.[B5], .[B5].End(xlDown))
  6.    If IsEmpty(d(a & "")) Then
  7.       ar(0) = Array(.[B4], .[C4], .[D4], .[E4])
  8.       ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  9.       d(a & "") = ar
  10.       Else
  11.       ay = d(a & "")
  12.       s = UBound(ay)
  13.       ReDim Preserve ay(s + 1)
  14.       ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  15.       d(a & "") = ay
  16.       Erase ay
  17.     End If
  18. Next
  19. For Each sh In Sheets
  20.    If d.exists(sh.Name) = True Then
  21.       ay = d(sh.Name)
  22.       sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  23.       d.Remove sh.Name
  24.     End If
  25. Next
  26. For Each ky In d.keys
  27.    With Sheets.Add(after:=Sheets(Sheets.Count))
  28.       .Name = ky
  29.        ay = d(ky)
  30.       .[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  31.     End With
  32. Next
  33. End With
  34. End Sub
½Æ»s¥N½X
¦^´_ 1# ¾Ç¨ì¦Ñ¦º
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¥»©«³Ì«á¥Ñ c_c_lai ©ó 2016-2-23 09:22 ½s¿è

¦^´_ 19# Hsieh
  1. sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
½Æ»s¥N½X
°õ¦æ¨ì¦¹¦æ¡A§Y²£¥Í "«¬ºA¤£²Å (#13)"

TOP

        ÀR«ä¦Û¦b : ¡i®É¶¡µLªk¾B¾×¡j©È®É¶¡®ø³u¡Aªá¤F³\¦h¤ß¦å¡A·QºÉ¦U¦¡¤èªk­n¾B¾×®É¶¡¡Aµ²ªG¬O¡G®ö¶O¤F§ó¦h®É¶¡¡A¥B¤@µL©Ò¦¨¡I
ªð¦^¦Cªí ¤W¤@¥DÃD