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

[µo°Ý] ¤À­¶¦¸ªºvba¼gªk

[µo°Ý] ¤À­¶¦¸ªºvba¼gªk

¦U¦ì¦n¡A³o¸Ì·Q½Ð±Ð¦U¦ì¦p¦ó½s¼g¤U¦Cªºvba


1.a/b/c ¤À§O¥Nªí«È¤á¥N¸¹

2. ex. a  ¦³2µ§¸ê®Æ ;b ¦³5µ§¸ê®Æ ¡Fc¦³1µ§¸ê®Æ

3. ¦bvba ªº¥¨¶°°õ¦æ«á¡C¥i±N  a ªº2¦C ®»¤J"worksheet (2)" ªº²Ä1­¶ ¡A bªº5¦C®»¤Jworksheet(2) ªº²Ä2­¶ ¡C¨Ì¦¸Ãþ±À¡A

note .

a. ¦b¨C­¶ªº¦C¼Æ³]©w¬°20¦C

b. ¦p¬Y¤@­Ó«È¤á¶W¥X¤@­¶¦¸ªº§e²{ ¡A¬Û¦P¤U¤@­Ó«È¤á¥H±µÄò¤W¤è«È¤á³Ì«á­¶¦¸ªº¤U¤@­¶¦¸¡C

·PÁ¦U¦ì¥ý¶i

¦^´_ 1# melvinhsu


ªO¤j¡A¦A·Ð½T»{ªþ¥ó¡C

¬¡­¶Ã¯12.zip (25.42 KB)

TOP

¦^´_ 1# melvinhsu
¸Õ¸Õ¬Ý¡G
  1. '¥Ñ¿é¤J¨ì¿é¥X
  2. Private Sub CommandButton1_Click()
  3.     Dim sh1, sh2, sh3 As Worksheet
  4.     Dim r1, i, lastRow1, lastRow2, lastRow3, msg As Integer
  5.     Dim «È¤á As String
  6.     Set sh1 = Sheets("¿é¤J")
  7.     Set sh2 = Sheets("¿é¥X")
  8.     Set sh3 = Sheets("¾ú¥v")
  9.    
  10.     sh2.Cells.Clear    '¥þ³¡²M°£ "¿é¥X"
  11.     sh2.ResetAllPageBreaks    '­«³]©Ò¦³ªº¤À­¶½u
  12.    
  13.     sh1.Rows("1:1").Copy sh2.Rows("1:1")   '½Æ»s "¿é¤J"ªº¼ÐÃD¦C ¨ì "¿é¥X"
  14.     lastRow1 = sh1.[A65536].End(xlUp).Row    '¨ú±o "¿é¤J"ªºÄæA ³Ì¤U­±«DªÅ¥Õ¦C ªº¦C¸¹
  15.     lastRow3 = sh3.[A65536].End(xlUp).Row    '¨ú±o "¾ú¥v" AÄæ³Ì¤U­±«DªÅ¥Õ¦C ¦C¸¹
  16.    
  17.    
  18.     '//////
  19.     '«Ø¥ß"¿é¥X"ªº¤£­«ÂЫȤá¦W³æ
  20.     '¤£­«Âпz¿ï, ±Nµ²ªG½Æ»s ÄæG(°²©w "¿é¤J"ÄæG ¥H«á¨S¸ê®Æ)
  21.     Set rng = sh1.[A1].Resize(lastRow1, 1)
  22.    
  23.     rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rng, _
  24.           CopyToRange:=sh1.Range("G1"), Unique:=True
  25.          
  26.     sh1.Columns("G:G").Copy sh2.Columns("A:A")   '½Æ»s "¿é¤J"ªºÄæG(¿z¿ïµ²ªG) ¨ì "¿é¥X"ªºÄæA
  27.     sh1.Columns("G:G").Delete     '§R°£ "¿é¤J"ªºÄæG
  28.    
  29.     lastRow2 = sh2.[A65536].End(xlUp).Row    '¨ú±o "¿é¥X" AÄæ³Ì¤U­±«DªÅ¥Õ¦C ªº¦C¸¹
  30.    
  31.     '//////
  32.     '¥Ñ¤U©¹¤WÂX®i¨C­Ó«È¤áªº¤u§@¦C(¨C­Ó«È¤á20¦C), ¨Ã¥[¤J¤À­¶½u
  33.     For i = 2 To lastRow2
  34.         sh2.HPageBreaks.Add Before:=sh2.Cells(i + 1, 1)     '´¡¤J¤ô¥­¤À­¶½u
  35.     Next
  36.     For i = lastRow2 To 2 Step -1
  37.         sh2.Cells(i + 1, 1).Resize(19, 1).EntireRow.Insert Shift:=xlDown
  38.     Next
  39.    
  40.     '//////
  41.     '±N"¿é¤J"ªº «È¤á¸ê®Æ½Æ»s¨ì"¿é¥X"
  42.     For r1 = 2 To lastRow1
  43.    
  44.         '¦pªG¬OªÅ¥Õ®æ, ´«¤U¤@µ§
  45.         If sh1.Cells(r1, 1) = "" Then Exit For
  46.         
  47.         '§_«h ±q "¿é¤J" ½Æ»s«È¤á¸ê®Æ ¨ì"¿é¥X"
  48.         «È¤á = sh1.Cells(r1, 1)
  49.         ½Æ»s«È¤á¸ê®Æ «È¤á, r1
  50.     Next
  51.    
  52.     '//////
  53.     '±N"¿é¤J"ªº «È¤á¸ê®Æ«O¦s¨ì"¾ú¥v"
  54.     sh1.[A2].Resize(lastRow1, 3).Copy sh3.Cells(lastRow1 + 1, 1)
  55.     msg = MsgBox("¤w±N¡i¿é¤J¡jªº«È¤á¸ê®Æ ½Æ»s¨ì¡i¾ú¥v¡j¤¤, " & Chr(10) _
  56.           & "­n²M°£¡i¿é¤J¡jªº«È¤á¸ê®Æ¶Ü?", vbYesNo)
  57.     If msg = vbYes Then
  58.         sh1.[A2].Resize(lastRow1, 3).Clear
  59.     End If
  60. End Sub


  61. Sub ½Æ»s«È¤á¸ê®Æ(ByVal «È¤á As String, ByVal r1 As Integer)
  62.     Dim sh1, sh2 As Worksheet
  63.     Dim i, lastRow2 As Integer
  64.     Dim cel, cel2, rng As Range
  65.     Set sh1 = Sheets("¿é¤J")
  66.     Set sh2 = Sheets("¿é¥X")
  67.    
  68.     lastRow2 = sh2.[A65536].End(xlUp).Row     '¨ú±o "¿é¥X" AÄæ³Ì¤U¤@¦C¦C¸¹
  69.     Set rng = sh2.[A1].Resize(lastRow2, 1)    '³]©w"¿é¥X"·j´M(Find)½d³ò
  70.    
  71.     '¨ú±o "¿é¥X"²Ä¤@µ§«È¤á ªº cel
  72.     Set cel = rng.Find(What:=«È¤á, After:=sh2.[A1], LookIn:=xlValues, _
  73.           lookat:=xlWhole, MatchByte:=True)
  74.       
  75.     '±N "¿é¥X"«È¤áªº²Ä¤@µ§¦C­È °£¥H20, ¦pªG¾l2,
  76.     '¦Ó¥B³o¤@µ§ªº¥ª¤@®æ(Offset(0, 1))¬OªÅ¥Õ®æ¡÷©|¥¼¦³«È¤á¸ê®Æ(¥u¦³«È¤á¦WºÙ)
  77.     '¡÷±q"¿é¤J" ½Æ»s«È¤á¸ê®Æ ¨ì"¿é¥X"
  78.     If cel.Row Mod 20 = 2 And cel.Offset(0, 1) = "" Then
  79.         sh1.Cells(r1, 1).Resize(1, 3).Copy cel
  80.     Else
  81.          
  82.         '¨ú±o"¿é¥X"«È¤á ªº ³Ì«á¤@µ§¦C­È+1
  83.         i = cel.Row
  84.         Do
  85.             i = i + 1
  86.         Loop Until sh2.Cells(i, 1) = "" Or sh2.Cells(i, 1) <> «È¤á
  87.         
  88.         '­Y ³Ì«á¤@µ§«È¤áªº¦C­È+1 ¬OªÅ¥Õ
  89.         '¡÷±q"¿é¤J" ½Æ»s«È¤á¸ê®Æ ¨ì"¿é¥X"(§t«È¤á¦WºÙ)
  90.         If sh2.Cells(i, 1) = "" Then
  91.             sh1.Cells(r1, 1).Resize(1, 3).Copy sh2.Cells(i, 1)
  92.             
  93.         '§_«h, "¿é¥X" ³Ì«á¤@µ§«È¤áªº¦C­È+1 ¬O¥t¤@¦ì «È¤á¦W³æ,
  94.         '¡÷³o¦ì«È¤áªº ªÅ¥Õ¦C ¤w¥Î§¹,
  95.         'ÂX®i³o¦ì«È¤áªºªÅ¥Õ¦C, ¨Ã¥[¤J¤À­¶½u
  96.         Else
  97.             sh2.Cells(i, 1).Resize(20, 1).EntireRow.Insert Shift:=xlDown
  98.             sh2.HPageBreaks.Add Before:=sh2.Cells(i, 1)
  99.         End If
  100.     End If
  101. End Sub
½Æ»s¥N½X

TOP

¦^´_ 2# melvinhsu
  1. Sub ex()
  2. Dim A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets(1)
  5. For Each A In .Range(.[A2], .[A2].End(xlDown))
  6.   If IsEmpty(d(A.Value)) Then
  7.      Set d(A.Value) = A.Resize(, 3)
  8.      Else
  9.      Set d(A.Value) = Union(d(A.Value), A.Resize(, 3))
  10.   End If
  11. Next
  12. End With
  13. With Sheets(2)
  14. .UsedRange.Offset(1).Clear '²MªÅ­ì¦³¸ê®Æ
  15. r = 2
  16. For Each ky In d.keys
  17. r = IIf(i = 0, 2, 1)
  18. d(ky).Copy .Cells(r + i * 20, 1) '½Æ»s¨ì¤u§@ªí2
  19. k = Int(d(ky).Count / 3 / 20) '­pºâ©Ò¥e­¶¼Æ
  20. i = i + k + 1
  21. Next
  22. End With
  23. End Sub
½Æ»s¥N½X
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

ÁÂÁÂ2¦ìªº¦^À³¡C«ü¾É

TOP

        ÀR«ä¦Û¦b : §Ñ¥\¤£§Ñ¹L¡A§Ñ«è¤£§Ñ®¦¡C
ªð¦^¦Cªí ¤W¤@¥DÃD