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

freeffly

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




·s¼WMicrosoft Excel ¤u§@ªí.rar (4.26 KB)

¤U¸ü¦¸¼Æ: 34

2011-11-22 15:09

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦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

Andy2483

¦^´_ 6# Hsieh


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

°õ¦æ«e:

¤U¸ü (150.88 KB)

2023-3-30 12:49

°õ¦æµ²ªG:

¤U¸ü (209.47 KB)

2023-3-30 12:49

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

freeffly

¦^´_ 6# Hsieh


    ÁÂÁª©¥D´£¨Ñ¨ç¼Æ¼gªk
   ¤S¦h¤@ºØ¾Ç²ß¤è¦¡

Hsieh

¦^´_ 5# freeffly

¨ç¼Æ¸Ñªk¡A¥ý±NA¡ABÄæ±Æ§Ç
·s¼WMicrosoft Excel ¤u§@ªí.zip (18.09 KB)

¤U¸ü¦¸¼Æ: 17

2011-11-25 20:01

freeffly

¦^´_ 4# GBKEE


    ÁÂÁª©¥D
   ¦¹¤èªk¤@¼Ë¥i¥H¸£µ¬¦³ÂI§Ö¥´µ²¤F
   ¦¬¤U¬ã¨s

GBKEE

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

freeffly

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

oobird

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