- ©«¤l
- 4901
- ¥DÃD
- 44
- ºëµØ
- 24
- ¿n¤À
- 4916
- ÂI¦W
- 43
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Office 20xx
- ¾\ŪÅv
- 150
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥x¥_
- µù¥U®É¶¡
- 2010-4-30
- ³Ì«áµn¿ý
- 2025-2-19
               
|
¦^´_ 34# iceandy6150
´êÓ¼ö¾x- Sub CreateTable()
- Dim i%, Ar(), Rng As Range, A As Range, sht As Object, ky As Variant, k&, s&
- Set sht = CreateObject("Scripting.Dictionary")
- Application.DisplayAlerts = False
- With Sheets("Sheet1")
- i = .Index + 1
- Do Until Sheets.Count < i '§R°£Sheet1¤§«áªº¤u§@ªí
- Sheets(i).Delete
- i = .Index + 1
- Loop
- For Each A In .Range(.[G2], .[G2].End(xlDown)) '¤ÀÃþÀx¦s
- Set Rng = Sheets("°Ñ·Óªí").[A:A].Find(A, lookat:=xlWhole) '§ä¨ì°Ñ·Ó
- If IsEmpty(sht(Rng.Offset(, 1).Value)) Then '¤ÀÃþ²Ä¤@Ó
- ReDim Preserve Ar(0)
- Ar(0) = Array(A.Offset(, -3).Value, "", "", "", A.Offset(, -1).Value, "", A.Offset(, -2).Value)
- sht(Rng.Offset(, 1).Value) = Ar
- Else '¤ÀÃþÄ~Äò§ä¨ì
- Ar = sht(Rng.Offset(, 1).Value)
- s = UBound(Ar)
- ReDim Preserve Ar(s + 1)
- Ar(s + 1) = Array(A.Offset(, -3).Value, "", "", "", A.Offset(, -1).Value, "", A.Offset(, -2).Value)
- sht(Rng.Offset(, 1).Value) = Ar
- Erase Ar
- End If
- Next
- For Each ky In sht.keys '¥Î¤ÀÃþ·í¦¨¯Á¤ÞÈ
- Ar = sht(ky)
- s = UBound(Ar) + 1
- With Sheets.Add(after:=Sheets(Sheets.Count)) '·s¼W¤u§@ªí
- .Name = ky '¥H¤ÀÃþ¬°ªí¦WºÙ
- Set Rng = Sheets("ªí®æ½d¥»").[A1:K22] 'ªí®æ½d¥»½d³ò
- Rng.Copy .[A1]: k = 0: .Cells(k + 2, 3) = ky
- For i = 0 To UBound(Ar) '¼g¤J¸ê®Æ
- .Cells(i + 7 + Int(i / 13) * 13, 4).Resize(, 7) = Application.Index(Ar, i)
- If (i + 1) Mod 13 = 0 Then k = k + 26: Rng.Copy .[A1].Offset(k, 0): .Cells(k + 2, 3) = ky '13µ§¬°¤@Óªí®æ
- Next
- End With
- Next
- 'Âà¦ÜÁ`ªí
- If MsgBox("¬O§_¦s¤JÁ`ªí", vbYesNo) = 6 Then .Range("A1").CurrentRegion.Offset(1).Copy Sheets("Á`ªí").Cells(.Rows.Count, 1).End(xlUp).Offset(3)
- MsgBox "¤ÀÃþ§¹¦¨"
- End With
- End Sub
½Æ»s¥N½X |
|