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

[µo°Ý] ½Ð¨D ¦Û°Ê¨ÌÄæ¦ì¤ÀÃþ¥¨¶° ­×§ï

[µo°Ý] ½Ð¨D ¦Û°Ê¨ÌÄæ¦ì¤ÀÃþ¥¨¶° ­×§ï

¥»©«³Ì«á¥Ñ tony0318 ©ó 2010-5-24 14:54 ½s¿è

½Ð°Ý©³¤Uµ{¦¡½X¡A­ì¥ý·|¨Ì·Ó²Ä¤@Äæ¦ìªº¤£¦P¦Û°Ê¤ÀÃþ¨ì¦U¤u§@ªí¡A
·Qª¾¹D¦p¦ó¥H²Ä¤TÄæ¦ì§@¬°¤ÀÃþ¡I¦]¬°¹ïµ{¦¡¤£À´¡A¥u¯àTRY¡AÁÂÁ¡C
  1. Sub ex()

  2. '

  3. Dim A As Range
  4. Set d = CreateObject("Scripting.Dictionary")
  5. With Sheet1
  6. For Each A In .Range(.[A2], .[A65536].End(xlUp))
  7.   If IsEmpty(d(A & "")) Then
  8.   Set d(A & "") = Union([A1:L1], A.Resize(, 12))
  9.   Else
  10.   Set d(A & "") = Union(d(A & ""), A.Resize(, 12))
  11.   End If
  12. Next
  13. For Each ky In d.keys
  14.    With Sheets.Add(after:=Sheets(Sheets.Count))
  15.    .Name = ky
  16.    d(ky).Copy .[A1]
  17.    End With
  18. Next
  19. End With

  20. '
  21. End Sub
½Æ»s¥N½X
§Æ±æ§e²{¦pªþ¥ó ¤ÀÃþ ZO.rar (11.29 KB)

¦^´_ 1# tony0318
  1. Sub ex()
  2. Dim A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheet1
  5. For Each A In .Range(.[C2], .[C65536].End(xlUp))
  6.   If IsEmpty(d(A & "")) Then
  7.   Set d(A & "") = Union([A1:L1], A.Offset(, -2).Resize(, 12))
  8.   Else
  9.   Set d(A & "") = Union(d(A & ""), A.Offset(, -2).Resize(, 12))
  10.   End If
  11. Next
  12. For Each ky In d.keys
  13.    With Sheets.Add(after:=Sheets(Sheets.Count))
  14.    .Name = ky
  15.    d(ky).Copy .[A1]
  16.    End With
  17. Next
  18. End With
  19. End Sub
½Æ»s¥N½X
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

ÁÂÁ¡I

¦n¹³¦³ÂI¬Ü¥Ø¤F¡I¡I

TOP

¦^´_ 1# tony0318
¯Â°Ñ¦Ò ¥t¤@ºØ¤è¦¡ ¨Ï¥Î °}¦C
Sub Ex()
    Dim Ar(), M$, A As Range, i%
    ReDim Ar(0)
    With Sheet1
       Set Ar(0) = .Range("A1").Resize(1, 12)
        M = .Range("C1")
        For Each A In .Range(.[A2], .[A65536].End(xlUp))
            If UBound(Filter(Split(M, ","), A(1, 3), True)) > -1 Then
                i = Application.Match(A(1, 3), Split(M, ","), 0)
                Set Ar(i - 1) = Union(Ar(i - 1), A.Resize(1, 12))
            Else
                M = M & "," & A(1, 3)
                ReDim Preserve Ar(UBound(Ar) + 1)
                Set Ar(UBound(Ar)) = Union(Ar(0), A.Resize(1, 12))
            End If
        Next
    End With
    On Error GoTo NewSheet
    For i = 1 To UBound(Split(M, ","))
        With Sheets(Split(M, ",")(i))
            .Cells.Clear
            Ar(i).Copy .Range("A1")
        End With
    Next
    Sheet1.Activate
    Exit Sub
NewSheet:
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .Name = Split(M, ",")(i)
    End With
    Resume
End Sub

TOP

¦^´_ 2# Hsieh


    ÁÂÁ«e½ú
½Ð±Ð«e½ú:
If IsEmpty(d(A & "")) Then
¬°¤°»ò­n¥[¤J¤@­ÓªÅ¦r¤¸?

¤µ¤Ñ²ß±o:
IsEmpty¬O¥Î¨Ó§P©wÅܼƬO§_ªì©l¤Æ
³]°j°é¥HÀx¦s®æ­È¬°KEY,©ñ¼ÐÃD¦C¶i¤Jitem°}¦C,©ñ¤J¦r¨å
³v¦C§Q¥ÎUnion©ñ¤J¬Û¦Pkeyªº¾ã¦C¸ê®Æ¨ìitem°}¦C¸Ì
°j°é¶]§¹«á!¦r¨å¸Ìªºitem°}¦C½Õ¥X¨Ó©ñ¦b·s¼Wªº¤u§@ªí¸Ì

TOP

¦^´_ 2# Hsieh


    ÁÂÁ«e½ú
§Ñ¤FA¬Oª«¥ó! ¦r¨åkey­n¬O¼Æ¦r©Î¦r¦ê
A & "" = A.Value

½m²ß®Éµo²{:
¤£³sÄòªºÀx¦s®æ¥i¥H³Q¦¬¶°°_¨Ó©ñ¤J¤u§@ªí¤¤
¦ý¬O¦pªG¸Ë¨ì°}¦C¸Ì´N·|¥u¸Ë²Ä¤@¬q¸ê®Æ!«á­±ªºÀx¦s®æ¤£·|¶i¥h!
­ì©l¸ê®Æ:


Union¦¬¶°¸ê®Æ¦b¤u§@ªí¸Ì:

Option Explicit
Sub Union_¦¬¶°¸ê®Æ¦b¤u§@ªí¸Ì()
Dim Arr, i&, xR As Range
Set xR = Cells(1, "C").Offset(, -2).Resize(, 12)
For i = 2 To Cells(Rows.Count, "C").End(3).Row
   If Cells(i, "C") = "A" Then
      Set xR = Union(xR, Cells(i, "C").Offset(, -2).Resize(, 12))
   End If
Next
Arr = xR
Workbooks.Add
xR.Copy [A1]
End Sub

Union¦¬¶°¸ê®Æ¦b°}¦C¸Ì¦A¶K¨ìªí¸Ì:

Option Explicit
Sub Union_¦¬¶°¸ê®Æ¦b°}¦C¸Ì¦A¶K¨ìªí¸Ì()
Dim Arr, i&, xR As Range
Set xR = Cells(1, "C").Offset(, -2).Resize(, 12)
For i = 2 To Cells(Rows.Count, "C").End(3).Row
   If Cells(i, "C") = "A" Then
      Set xR = Union(xR, Cells(i, "C").Offset(, -2).Resize(, 12))
   End If
Next
Arr = xR
Workbooks.Add
[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-10-14 14:52 ½s¿è

¦^´_ 2# Hsieh


    «e½ú§A¦n!
«á¾Ç¾q¶w!¨S¦³¥¿²Î¾Ç²ß,³£¥H¥ý¤J¬°¥Dªº¤è¦¡¾Ç²ß!
©Ò¥H±`±`³£¬O¿ù¤¤¾Ç,¹J¨ì®À§é¦AºCºC±ÀºV,¬°¤°»ò·|¿ù?
ªá«Ü¦h®É¶¡¬ã¨s¦UºØ±¡¹Ò¥Î¦Û¤v»{¬°¹ïªº§Þ¥©¸Õ¸Õ¬Ý!
¾Ç±o«ÜºC!¹B¥Î«e½ú­Ìªº©«¤l¾Ç²ß!¦p¦³«_¥Ç ½Ð¨£½Ì!

«á¾Ç¤@¶}©lªº¾Ç²ß«e½ú½d¨Òªº¤ß±o´N¿ù¤F!
## ³]°j°é¥HÀx¦s®æ­È¬°KEY,©ñ¼ÐÃD¦C¶i¤Jitem°}¦C,©ñ¤J¦r¨å ##
©ñ¼ÐÃD¦C¶i¤Jitemªº¬Oª«¥ó(Àx¦s®æ)

§â­ì©l¸ê®Æ³¡¤ÀÀx¦s®æ¥[¶À©³¦â:


«e½úªº½d¨Ò·|³s¦P®æ¦¡¤@°_ COPY ¨ì·s¤u§@ªí:


«á¾Ç¥ý¤J¬°¥D¥H¬°©ñ¶i¦r¨åªº¤@©w¬O°}¦C
«á¨Ó¤~µo²{©ñ¦b¦r¨å¸Ìªº°}¦C¬O­n©I¥s¥X¨Ó¤~¯à­Ë¶i¸ê®Æ
¦Ó¥B¨S¦³®æ¦¡
¥H¤U¬O«á¾Ç¬ã¨sªº¤ß±o:


Sub ¦b°}¦C¸Ì_¦¬¶°¸ê®Æ¦A¶K¨ìªí¸Ì_¤£§t®æ¦¡()
Dim Arr(1 To 999, 1 To 12), i&, xR As Range, xD, x, y
Set xD = CreateObject("Scripting.Dictionary")
y = 1
For x = 1 To 12
   Arr(1, x) = Cells(1, x)
Next
For Each xR In Range([C1], [C65536].End(xlUp))
   If xR = "A" Then
      y = y + 1
      For x = 1 To 12
         Arr(y, x) = Cells(xR.Row, x)
      Next
   End If
Next
xD(1) = Arr
Workbooks.Add
[A1].Resize(999, 12) = xD(1)
End Sub

Sub ¦bITEM¸Ì_¦¬¶°¸ê®Æ¦A¶K¨ìªí¸Ì_·|¶]¦ý¬O¨S¦³¸ê®Æ()
Dim Arr(1 To 999, 1 To 12), i&, xR As Range, xD, x, y
Set xD = CreateObject("Scripting.Dictionary")
xD(1) = Arr
y = 1
For x = 1 To 12
   xD(1)(1, x) = Cells(1, x)
Next
For Each xR In Range([C1], [C65536].End(xlUp))
   If xR = "A" Then
      y = y + 1
      For x = 1 To 12
         xD(1)(y, x) = Cells(xR.Row, x)
         MsgBox xD(1)(y, x)
      Next
   End If
Next
Workbooks.Add
[A1].Resize(999, 12) = xD(1)
End Sub

2022-10-14_141313.JPG (40.98 KB)

2022-10-14_141313.JPG

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-10-18 08:51 ½s¿è

¦U¦ì«e½ú¦n
¤µ¤Ñ½m²ß°}¦C»y¦r¨å
¤ß±oµù¸Ñ¦p¤U:
Option Explicit
Sub TEST()
Dim Arr, Brr(1 To 999, 1 To 12), Crr, c&, i&, x&, R&, T, Y, N, j, Z
'¡ô«Å§iÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OY¬O¦r¨å
Set Arr = [¤u§@ªí1!A1].CurrentRegion
'¡ô¥O Brr¬O [A1]¬Û¾F«DªÅ®æ©Ò¦ê³s°_¨ÓªºÀx¦s®æ,ÂX®i¨ì¤è¥¿°Ï°ìªº³Ì¤p½d³òÀx¦s®æ
c = [¤u§@ªí1!A1].End(xlToRight).Column
'¡ô¥OC¬O¦¹ªíªºÄæ¼Æ
R = [¤u§@ªí1!A1].End(xlDown).Row
'¡ô¥OR¬O¦¹ªíªº¦C¼Æ
For i = 2 To R
'¡ô³]°j°é±q2¶}©l¨ì¦¹ªíªº¦C¼Æ
   T = Arr(i, 3)
   '¡ô¥OT¬O CÄ涵¥Ø¦WºÙ
   Crr = Y(T & "|") '#1
   '¡ô¥OCrr¬OY¦r¨å¸Ìªº ¶µ¥Ø¦WºÙ&"|"¦r¦ê ¬°keyªºitem
   Y(T) = Y(T) + 1 '@1
   '¡ô¥O¶µ¥Ø¦WºÙ ¬°key,item²Ö¥[1,³o¬O«á­±¥Î¨Ó«ü©w°}¦C¦C¼Æªº
   ',¦p @1 ¼Ðµù
    If Not IsArray(Crr) Then
    '¡ô¦pªG§P©w Crr ÁÙ¤£¬O°}¦C
       Y(T) = Y(T) + 1
       '¡ô¥O¶µ¥Ø¦WºÙ ¬°key,item²Ö¥[1,³o¬O«á­±¥Î¨Ó«ü©w°}¦C¦C¼Æªº
       ',¦p @2 ¼Ðµù!³o¸Ì+1¬O¬°¤FªÅ¥X¤@¦Cµ¹¼ÐÃD¦C¥Îªº

       Crr = Brr
       '¡ô¥OCrrÅܦ¨¤@­Ó¤W­zBrr(1 To 999, 1 To 12)ªÅ°}¦C
       ',©Ò¥HBrr±qÀY¨ì§À³£¬O¤@­ÓªÅªº®e¾¹

    End If
    For j = 1 To 12
    '³]°j°é±N¸ê®Æ±a¤JCrr°}¦C
       Crr(Y(T), j) = Arr(i, j) '@1
       If Y(T) = 2 Then   '@2
       '¡ô¦pªG¦¹®Éªº°}¦C¼g¤J¬O¦b²Ä2¦C
          Crr(1, j) = Arr(1, j)
          '¡ô´N¤@°_§â¼ÐÃD¦C¼g¶i¥h°}¦C¸Ì
       End If
    Next j
    Y(T & "|") = Crr  '#1
    '¡ô¥O ¶µ¥Ø¦WºÙ&"|"¦r¦ê ¬°key ,¥OCrr¬°¥¦ªºitem,
Next
'¡ô°j°éÁ`µ²:
'°j°é·|Åý¦r¨å¸Ì¸Ë¶i¼Æ¦r.¦r¦ê.°}¦C

Workbooks.Add
For Each Z In Y.KEYS
'¡ô³]¶¶°j°é¥OZ¬OY¦r¨å¸Ìkeyªº¤@­û
   If InStr(Z, "|") Then
   '¡ô¦pªGZ³okey¦r¦ê¸Ì¦³ "|" ²Å¸¹,¥Nªí¥Lªºitem¬O°}¦C
   '§Ú­Ì´N¬O­n½Õ¥X°}¦C©ñ¦b·s¤u§@ªí¸Ì,¦p #1 ¼Ðµù
      Crr = Y(Z)
      '¡ô¥ÎCrr ¸Ë³oY(Z)°}¦C¨Ó¬Ý¤ñ¸û²ßºD!¬Ý¨ì¬A©·()´N®`©È!
      With Sheets.Add(after:=Sheets(Sheets.Count))
      '¡ô¦b¤W¤è·s¶}ªº¬¡­¶Ã¯³Ì«á¤u§@ªí«á­±¦A·s¶}¨Ì¤u§@ªí
         .Name = Replace(Z, "|", "")
         '¡ô¤u§@ªí¦W¬O ¶µ¥Ø¦WºÙ&"|"¦r¦ê ¥h±¼ "|" ²Å¸¹
         .[A1].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
         '¡ô§â°}¦C±q[A1]¶}©l¶K¶iÀx¦s®æ¸Ì¤F!
         .[I:J].NumberFormatLocal = "yyyy/m/d"
         '¡ô¥O[I:J]Ä檺®æ¦¡¬O ¦è¤¸4½X¦~ /¯à1½X´N¤£­n¨â½Xªº¤ë/¤é
         .Cells.Columns.AutoFit
         '¡ô¥O¾ãªíªº©Ò¦³Äæ¦ì¦Û°Ê½Õ¾ãÄæ¼e
      End With
   End If
Next
End Sub
Àµ½Ð¦U¦ì«e½ú«ü¥¿¨Ã«ü¾É!

TOP

        ÀR«ä¦Û¦b : ¦³®É·í«äµL®É­W¡A¦n¤Ñ­n¿n«B¨Ó³¡C
ªð¦^¦Cªí ¤W¤@¥DÃD