¸ê®Æ¬Û¦P±Æ¦b¦P¤@¦Cªº°ÝÃD

lionliu

¦U¦ì¤j¤j·Q½Ð±Ð§Ú¦³¦pªþ¥óªº³øªí§Ú­n¦p¦ó¤~¯à§Ö³t§¹¦¨
DATA.rar (7.65 KB)

¤U¸ü¦¸¼Æ: 19

2012-4-3 12:32

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾Ç¤µ¤Ñ½m²ß°}¦C»P¦r¨å,±N°}¦C¤@¦¸¼g¤JÀx¦s®æ,½m²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Sub TEST_1()
Dim Brr, Crr, V, Y, R&, C%, i&, T$, xR As Range, Ma%
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, "A").End(3)): Brr = xR
ReDim Crr(1 To UBound(Brr), 1 To Columns.Count - 14)
For i = 1 To UBound(Brr)
   T = Brr(i, 2)
   If Y(T & "/R") = "" Then
      R = R + 1: Y(T & "/C") = 1
      Y(T & "/R") = R: Crr(R, 1) = Brr(i, 2)
      Else
         Y(T & "/C") = Y(T & "/C") + 1
         Crr(Y(T & "/R"), Y(T & "/C")) = Brr(i, 1)
   End If
   If Y(T & "/C") > Ma Then Ma = Y(T & "/C")
Next
[N1].Resize(, Ma).EntireColumn.Clear
[N7].Resize(R, Ma) = Crr: [N6] = [B1]
[N7].CurrentRegion.Borders.LineStyle = 1
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub

Andy2483

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

°õ¦æ«e:

¤U¸ü (133.04 KB)

2023-4-6 16:23

°õ¦æµ²ªG:

¤U¸ü (152.35 KB)

2023-4-6 16:23

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, R&, C%, i&, T$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, "A").End(3)): Brr = xR
For i = 1 To UBound(Brr)
   T = Brr(i, 2): Y(T) = Y(T) + 1: If Y(T) > C Then C = Y(T)
Next
ReDim Crr(1 To Y.Count, 1 To C): V = Y.keys: Y.RemoveAll
For i = 1 To UBound(Brr)
   T = Brr(i, 2): If Y(T & "/R") = "" Then R = R + 1: Y(T & "/R") = R
   Y(T & "/C") = Y(T & "/C") + 1: Crr(Y(T & "/R"), Y(T & "/C")) = Brr(i, 1)
Next
[N:IV].Clear
[N7].Resize(UBound(V) + 1, 1) = Application.Transpose(V)
[O7].Resize(UBound(Crr), UBound(Crr, 2)) = Crr: [N6] = [B1]
[N7].CurrentRegion.Borders.LineStyle = 1
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr, V
End Sub

GBKEE

¦^´_ 8# hugh0620
¥Ñ¥ª¦V¥k   ¥Ñ¥k¦V¥ª  ÀH­Ó¤H³ß¦n³£¥i¥H

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim A As Range, xf As Integer, xC As Integer
   
4.     Sheet1.Activate
   
5.     'Sheets("­ì©l¸ê®Æ").Activate
   
6.     Columns("D:IV") = ""
   
7.     Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D6"), Unique:=True
   
8.     For Each A In Range([B2], [B65536].End(xlUp))
   
9.         xf = Application.Match(A, Columns("D"), 0)
   
10.         xC = Application.CountA(Range(Cells(xf, "D"), Cells(xf, "D").End(xlToRight)))
    
11.         Cells(xf, "D").Offset(, xC) = A.Offset(, -1)
    
12.     Next
    
13. End Sub

½Æ»s¥N½X

hugh0620

¦^´_ 6# GBKEE

  ¬Ý¨ìG¤j¸òr¤jªº¼gªk~ Áö¦³¤£¦P~
  ¦ý¦³¤@ÂI¬O¬Û³qªº¤j®a³£¬O±q³Ì¥kÃ䩹³Ì¥ªÃä¶ñ¤J¸ê®Æ
  range("IV"& n).end(xltoleft).offset(0,1)
  «ç»ò³£¨S¦³¤H¼g¨ä¥L¤è¦¡©O??

lionliu

¦n´Î°Ú·PÁ¦U¦ì¤j¤jÀ°¦£²{¦b´ú¸Õ¤¤

GBKEE

¦^´_ 5# register313
§Úªº¤u§@¥Î¤£¤WPCªº,¬O¿³½ìÅX¨Ï¨Ó¾Ç²ß.¦³®É¤]¬O¦^ÂЪº¤C¹s¤K¸¨¦a.

register313

¦^´_ 3# GBKEE

GBKEEª©¥Dªº«ü¾É»PÀ°¦£,¤p§Ì¥Ã»·°O±o

¯u¥¿¶i¤J½×¾Â¾Ç²ß,¤j¬ù¬O¥h¦~10¤ë¥ª¥k
¨º®ÉVBAªº³¡¥÷,¤@ª½¦bRange,Cells,Select,For...Nextµ¥°ò¥»»yªkªº¨Ï¥Î
¨ì¥Ø«e,À³¸Ó»¡VBA¦³¤@¨Ç°ò¦,¤£¹LÁ`ı±o¤@ª½¦b¦P¼Ëªº¦a¤è¶¨Ó¶¥h,µLªk¬ð¯}
­ì¦]¦Û¤v²M·¡
1.¤u§@¨ÃµL¦¹»Ý¨D
2.¦Û¤v¨Ã«D»{¯u¾Ç²ß(³o¬O¥D¦])

¤W½×¾Âªº­ì¦]
1.¾Ç²ß
2.À°§U§O¤H,¦Û¤v¤]·|¦³¦¨´N·P
3.´î¤Ö´X¦ì¶Wª©,ª©¥Dªº­t¾á(À³¸Ó¨S¦³¸ê®æ»¡³o¼Ëªº¸Ü)
   §Úªº¤@¨Ç¸Ñµª¬O°ò¦ª©¥»(¤£¬O¦nªºµª®×,¥u§Æ±æ¨S¦³¿ù»~)

hugh0620

¦^´_ 1# lionliu

²Â¤èªk~ ¥i¥H¥Î~ ¦ýÁÙ¬O­n¨Ì§Aªº­nªºµ²ªG¦A¥h½Õ¾ã~

1. Sub EX()
   
2. For Each A In Range("B2:B21")
   
3.     B = Application.Match(A, Sheet1.Range("D7:D20"), 0)
   
4.     Cells(6 + B, 255).End(xlToLeft).Offset(0, 1) = A.Offset(0, -1)
   
5.     '6+Bªº¥Îªk¬Oªí¬O±q²Ä6¦C¥H«á¡A¦]match¬O¬Û¹ï¦ì¸m
   
6.     '¨Ò¦p§¹¦¨ªíA¬O¬Û¹ï¦ì¸mªº²Ä1¦C¡A©Ò¥H6+1=7
   
7.     '§¹¦¨ªíB¬O¬Û¹ï¦ì¸mªº²Ä2¦C¡A©Ò¥H6+2=8
   
8. Next
   
9. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 2# register313
¤£¥Î¦r¨åª«¥ó¥i¤Ö¥Î¤@¦¸°j°é, ³o¤£¿ù ,¥i¦A²¤Æ¤@¤U

1. Sub Ex()
   
2.     Dim A As Range, xf As Integer
   
3.     Sheet1.Activate
   
4.     'Sheets("­ì©l¸ê®Æ").Activate
   
5.     Columns("D:IV") = ""
   
6.     Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D6"), Unique:=True
   
7.     For Each A In Range([B2], [B65536].End(xlUp))
   
8.         xf = Application.Match(A, Columns("D"), 0)
   
9.         Cells(xf, "IV").End(xlToLeft).Offset(, 1) = A.Offset(, -1)
   
10.     Next
    
11. End Sub

½Æ»s¥N½X