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

[µo°Ý] (¤w¸Ñ¨M)¦p¦ó¦C¥X¬Û¦P³¡ªùªº­û¤u

[µo°Ý] (¤w¸Ñ¨M)¦p¦ó¦C¥X¬Û¦P³¡ªùªº­û¤u

¥»©«³Ì«á¥Ñ freeffly ©ó 2012-2-22 16:53 ½s¿è

·Q±NAÄæ¸òBÄ檺¸ê®Æ³B²z¦¨¹³FÄæ¸òGÄ樺¼Ë
²Ä¤@®æ¬O³¡ªù²Ä¤G®æ¤§«áªº¬O¸Ó³¡ªù­û¤u
¨Ì§Ç±NAÄæ¸òBÄ檺¸ê®Æ³B²z§¹




·s¼WMicrosoft Excel ¤u§@ªí.rar (4.26 KB)
¦r¨å¨â¦U¦r ÁÙ¯uÃø²z¸Ñ

  1. Sub yy()
  2.     Set d = CreateObject("Scripting.Dictionary")
  3.     arr = [a1].CurrentRegion
  4.     For i = 2 To UBound(arr)
  5.         If Not d.exists(arr(i, 1)) Then
  6.             d(arr(i, 1)) = arr(i, 2)
  7.         Else
  8.             d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
  9.         End If
  10.     Next
  11.     c = 6
  12.     For Each k In d.keys
  13.         d(k) = Split(d(k), ",")
  14.         Cells(1, c) = k
  15.         Cells(2, c).Resize(UBound(d(k)) + 1, 1) = Application.Transpose(d(k))
  16.         c = c + 1
  17.     Next
  18. End Sub
½Æ»s¥N½X

TOP

¦^´_ 2# oobird
ÁÂÁª©¥D¦^ÂÐ
¤U­±¬O§Ú­è·Q¥X¨Óªº¤è¦¡
¤èªk®t¯u¦h
¦Ó¥B§Úªº¤è¦¡¥i¥H»¡¬O¦³ÂIÄúÀ¿(±¼º£)
ª©¥D¤S¨Ï¥Î¤F§Ú¤£¤Ó·|ªº¦r¨å
¥ý¦¬¤U¬ã¨s
·P®¦
  1. Sub ´ú¸Õ()
  2.     Application.ScreenUpdating = False
  3.     Range("F2").Resize(Range("A65536").End(xlUp).Row, Range("iv1").End(xlToLeft).Column).Clear
  4.     Columns("H:H").Clear
  5.     Range("A1:A" & Range("A65536").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
  6.         "H1"), Unique:=True
  7.     Range("F1").Resize(, Range("H65536").End(xlUp).Row - 1) = Application.Transpose(Range("H2:H" & Range("H65536").End(xlUp).Row))
  8.     Range("H2:H" & Range("H65536").End(xlUp).Row).Clear
  9.     For i = 2 To Range("B65536").End(xlUp).Row
  10.     For n = 6 To [iv1].End(xlToLeft).Column
  11.     If Cells(1, n) = Cells(i, 1) Then
  12.         Cells(i, n) = Cells(i, 2)
  13.     End If
  14.     Next
  15.     Next
  16.     For n = 6 To [iv1].End(xlToLeft).Column
  17.     Columns(n).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
  18.     Next
  19. End Sub
½Æ»s¥N½X
¦r¨å¨â¦U¦r ÁÙ¯uÃø²z¸Ñ

TOP

¦^´_ 3# freeffly
¥t¤@¼gªk
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, i As Integer, PastRng As Range, Ar
  4.     'Ar = Range("A1").CurrentRegion
  5.     'Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlYes
  6.     '¦p¸ê®Æ¨S¦³±Æ§Ç¥[¥Î¤W­±µ{¦¡½X
  7.     Set Rng = Range("A2")
  8.     Set PastRng = Range("F1")
  9.     PastRng.CurrentRegion = ""
  10.     i = 2
  11.     Do While Rng <> ""
  12.         If Rng(i) <> Rng Then
  13.             PastRng = Rng
  14.             PastRng(2).Resize(i - 1) = Range(Rng, Rng(i - 1)).Offset(, 1).Value
  15.             Set Rng = Rng(i)
  16.             Set PastRng = PastRng.Offset(, 1)
  17.             i = 2
  18.         Else
  19.             i = i + 1
  20.         End If
  21.     Loop
  22.    'Range("A1").CurrentRegion = Ar    '¦p¸ê®Æ¨S¦³±Æ§Ç¥[¦¹µ{¦¡½X
  23. End Sub
½Æ»s¥N½X

TOP

¦^´_ 4# GBKEE


    ÁÂÁª©¥D
   ¦¹¤èªk¤@¼Ë¥i¥H¸£µ¬¦³ÂI§Ö¥´µ²¤F
   ¦¬¤U¬ã¨s
¦r¨å¨â¦U¦r ÁÙ¯uÃø²z¸Ñ

TOP

¦^´_ 5# freeffly

¨ç¼Æ¸Ñªk¡A¥ý±NA¡ABÄæ±Æ§Ç
·s¼WMicrosoft Excel ¤u§@ªí.zip (18.09 KB)
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 6# Hsieh


    ÁÂÁª©¥D´£¨Ñ¨ç¼Æ¼gªk
   ¤S¦h¤@ºØ¾Ç²ß¤è¦¡
¦r¨å¨â¦U¦r ÁÙ¯uÃø²z¸Ñ

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-3-30 12:59 ½s¿è

¦^´_ 6# Hsieh


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

°õ¦æ«e:


°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Dim Brr, Crr, i&, xR, Y
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, 1).End(3)): Brr = xR
For i = 1 To UBound(Brr)
   If Y(Brr(i, 1)) = "" Then Y(Brr(i, 1)) = Y.Count
Next
With [K1].Resize(, Y.Count)
   .EntireColumn.ClearContents
   .Value = Y.keys
End With
ReDim Crr(UBound(Brr), 1 To Y.Count)
For i = 1 To UBound(Brr)
   Crr(Y(Brr(i, 1) & "|"), Y(Brr(i, 1))) = Brr(i, 2)
   Y(Brr(i, 1) & "|") = Y(Brr(i, 1) & "|") + 1
Next
[K2].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß¦r¨å¤¤ªº°}¦C½s¿è,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Sub TEST_2()
Dim Brr, Crr, i&, R&, xR, Y, Z, V, N
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, 1).End(3)): Brr = xR
R = UBound(Brr): ReDim A(1 To R, 0)
For i = 1 To R
   If Not IsArray(Brr(i, 1)) Then Y(Brr(i, 1)) = A
Next
With [K1].Resize(, Y.Count)
   .EntireColumn.ClearContents: .Value = Y.keys
End With
For i = 1 To R
   Z = Y(Brr(i, 1)): Y(Brr(i, 1) & "|") = Y(Brr(i, 1) & "|") + 1
   Z(Y(Brr(i, 1) & "|"), 0) = Brr(i, 2): Y(Brr(i, 1)) = Z
Next
For Each V In Y.Items
   If IsArray(V) Then N = N + 1: [K2].Item(1, N).Resize(R, 1) = V
Next
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : ¨C¤ÑµL©Ò¨Æ¨Æ¡A¬O¤H¥Íªº®ø¶OªÌ¡A¿n·¥¡B¦³¥Î¤~¬O¤H¥Íªº³Ð³yªÌ¡C
ªð¦^¦Cªí ¤W¤@¥DÃD