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

[µo°Ý] ¸õ¸¹½ü­Èªí

¥»©«³Ì«á¥Ñ yen956 ©ó 2014-4-8 16:24 ½s¿è

¤@¡B«Ø¥ß¾ã¦~«×¡i¥­¤é½ü¯Z¦W³æ¡j¼È¦sªí, ¨ÑÁ`ªí§ì¦W³æ¥Î
vba Code ¦p¤U¡G
  1. Option Explicit
  2. '±Æ¥­¤é½ü¯Zªí
  3. Private Sub CommandButton1_Click()
  4.     Dim i, rowA, ½ü¼Æ As Integer
  5.     Dim rng, cel As Range
  6.     MsgBox "±N²M°£¥kªí­ì¦³¸ê®Æ, ¬O§_Ä~Äò?", vbYesNo
  7.    
  8.     Application.ScreenUpdating = False   'Ãö³¬¿Ã¹õ¨ê·s
  9.    
  10.     '¥h°£®æ½u, ¥H¨¾ .End »~§P
  11.     [A:A].Borders.LineStyle = 0
  12.    
  13.     rowA = [A2].End(xlDown).Row
  14.    
  15.     '¥­¤é¤@¦~¬ù260¤Ñ, ¥H280¤Ñ­p
  16.     ½ü¼Æ = (280 / (rowA - 1))
  17.    
  18.     '¥h°£®æ½u, ¥H¨¾ .End »~§P
  19.     [G2].Resize(rowA, ½ü¼Æ).Borders.LineStyle = 0
  20.    
  21.     '²M°£±Æ¯Zªí
  22.     [G2].Resize(rowA + 20, ½ü¼Æ + 20) = ""
  23.    
  24.     '±N ÄæA ­È¤é¤H­û¦W³æ ½Æ»s¨ì ÄæG
  25.     [A2].Resize(rowA, 1).Copy [G2]
  26.    
  27.     For i = 1 To ½ü¼Æ - 1
  28.    
  29.         '±N ·í«eÄæ ªº ­È¤é¤H­û¦W³æ ½Æ»s¨ì «á¤@Äæ
  30.         Cells(2, 6 + i).Resize(rowA, 1).Copy Cells(2, 7 + i)
  31.         
  32.         '®Ú¾Ú [D5](¨C½ü¸õ´X¸¹) ªº­È, ¨M©w­n°Å¤U¦h¤ÖÀx¦s®æ, ¶K¨ì³Ì¤U­±
  33.         Cells(2, 7 + i).Resize([D5], 1).Cut
  34.         Cells(rowA + 1, 7 + i).Insert Shift:=xlDown
  35.     Next
  36.    
  37.     Application.ScreenUpdating = True     '¥´¶}¿Ã¹õ¨ê·s
  38. End Sub
½Æ»s¥N½X
¦p¤U¹Ï¡G

¤G¡B«Ø¥ß¾ã¦~«×¡i°²¤é½ü¯Z¦W³æ¡j¼È¦sªí, ¨ÑÁ`ªí§ì¦W³æ¥Î
¦ý¬O, ³o¥÷¦W³æ¦b±Æ§Ç¤W¥¿¦n¤W­±¬Û¤Ï,
¤~¤£·|¦³¤H©ê«è»¡, «ç»ò¦Ñ¬O±q§Ú¶}©l±Æ°_,
vba Code ¦p¤U¡G
  1. Option Explicit
  2. '±Æ°²¤é½ü¯Zªí
  3. Private Sub CommandButton1_Click()
  4.     Dim i, rowA, ½ü¼Æ As Integer
  5.    
  6.     MsgBox "±N²M°£¥kªí­ì¦³¸ê®Æ, ¬O§_Ä~Äò?", vbYesNo
  7.    
  8.     Application.ScreenUpdating = False   'Ãö³¬¿Ã¹õ¨ê·s
  9.    
  10.     '¥h°£®æ½u, ¥H¨¾ .End »~§P
  11.     [A:A].Borders.LineStyle = 0
  12.    
  13.     rowA = [A2].End(xlDown).Row
  14.    
  15.     '¨Ò°²¤é¤@¦~¬ù115¤Ñ, ¥H120¤Ñ­p
  16.     ½ü¼Æ = (120 / (rowA - 1))
  17.    
  18.     '¥h°£®æ½u, ¥H¨¾ .End »~§P
  19.     [G2].Resize(rowA, ½ü¼Æ).Borders.LineStyle = 0
  20.    
  21.     '²M°£±Æ¯Zªí
  22.     [G2].Resize(rowA + 20, ½ü¼Æ + 20) = ""
  23.    
  24.     '±N ÄæA ­È¤é¤H­û¦W³æ¡i¤Ï¦V¡j½Æ»s¨ì ÄæG
  25.     For i = 2 To rowA
  26.         Cells(i, 1).Copy Cells(Abs(i - rowA) + 2, 7)
  27.     Next
  28.    
  29.     For i = 1 To ½ü¼Æ - 1
  30.    
  31.         '±N ·í«eÄæ ­È¤é¤H­û¦W³æ ½Æ»s¨ì «á¤@Äæ
  32.         Cells(2, 6 + i).Resize(rowA, 1).Copy Cells(2, 7 + i)
  33.         
  34.         '®Ú¾Ú [D5](¨C½ü¸õ´X¸¹) ªº­È, ¨M©w­n°Å¤U¦h¤ÖÀx¦s®æ, ¶K¨ì³Ì¤U­±
  35.         Cells(2, 7 + i).Resize([D5], 1).Cut
  36.         Cells(rowA + 1, 7 + i).Insert Shift:=xlDown
  37.     Next
  38.     '
  39.     Application.ScreenUpdating = True     '¥´¶}¿Ã¹õ¨ê·s
  40. End Sub
½Æ»s¥N½X
¦p¤U¹Ï¡G

(¥¼§¹)

TOP

¦^´_ 3# h60327
¦p¦ó»s§@¸õ¸¹½ü­Èªí(¤G)
¤T¡B¤Wºô§ì²{¦¨ªº¤ë¾äªí
¦p¤U¹Ï¡G(§A¤]¥i§ì¨ä¥Lªº¤ë¾äªí, ¨Ò¦p¡G§A¥i¥H§ì¤º¬F³¡ªº¡u¿ì¤½¤é¾äªí¡v)
   
¨Ã­×§ï¦¨¤U¦C®æ¦¡, ·í§@¥»³nÅ骺Á`ªí
­×§ï­«ÂI¡G
1. ±N1¨ì12¤ë¥Ñ¤W¨ì¤U, ³sÄò¨Ã±Æ
2. ¥­¤éªº¡i¤é´Á¡j¦rÅé¦âÃC¦â¬°¶Â¦â, °²¤é¬°¬õ¦â©ÎÂŦâ
(»P­I´ºÃC¦âµLÃö)
3. ¨C¤ë©T©w20¦C(§t¼ÐÃD), ¤£¨¬20¦C, À³¸É¨¬20¦C
¦p¤U¹Ï:

¦bÁ`ªí¤¤, §Ú­Ì¥[¤J¤F¤U¦C¥\¯à¡G
(¤H¨Æ°ÝÃD, Ãø§K¸I¤W³o¨Ç°ÝÃD)
A¡B³B²zÂ÷¾¤H­û
vba Code ¦p¤U¡G
  1. '³B²zÂ÷¾¤H­û
  2. Private Sub CommandButton2_Click()
  3.     Dim sh As Object, rng1, cel As Range
  4.     Dim sh1 As Worksheet
  5.    
  6.     Set sh1 = Sheets("Á`ªí")
  7.    
  8.     Application.ScreenUpdating = False          'Ãö³¬¿Ã¹õ¨ê·s
  9.    
  10.     sh1.[N8] = "=MATCH(RC[-1],x,0)+1"
  11.    
  12.     ³B²zÂ÷¾¤H­û "¥­¤é"
  13.     ³B²zÂ÷¾¤H­û "°²¤é"
  14.    
  15.     '//////////////////////
  16.     '¥H¤U³B²z Á{®É¥N¯Z¤H­û
  17.    
  18.     Set rng1 = sh1.Cells(sh1.[P4] * 20 - 16, 1).Resize(18, 7)
  19.    
  20.     '¦b·í¤ë­È¶Ôªí¤W, ¬d§ä Â÷¾¤H­û ¦W³æ, ¨Ã¶Çµ¹ cel
  21.     Set cel = rng1.Find(What:=sh1.[M8], LookIn:=xlValues, _
  22.         LookAt:=xlWhole)
  23.         
  24.     '¦pªG·í¤ë­È¶Ôªí¤W, ¦³§ä¨ì Â÷¾¤H­û ¦W³æ
  25.     If Not cel Is Nothing Then
  26.    
  27.         If cel.Offset(-2, 0).Font.ColorIndex = 1 Then
  28.             Set sh = Sheets("¥­¤é")
  29.         Else
  30.             Set sh = Sheets("°²¤é")
  31.         End If
  32.         
  33.         '¦pªG [G2] ¤Î [H2] §¡¬°ªÅ¥Õ, ªí¥Ü¤wµL¼È¦s¦W³æ¥i¥Î
  34.         If sh.[G2] = "" And sh.[H2] = "" Then
  35.             MsgBox "µL¼È¦s¦W³æ¥i¥Î!!", vbExclamation
  36.             Exit Sub
  37.         End If
  38.         
  39.         '­Y [G2] ¬°ªÅ¥Õ®æ(«h ÄæG ¬°ªÅ¥ÕÄæ), ¦Ó [H2] ¤£¬OªÅ¥Õ®æ, «h
  40.         If sh.[G2] = "" And sh.[H2] <> "" Then
  41.                         
  42.             '§R°£ ÄæG, ¨Ã¦V¥ª²¾(¨ú±o ÄæH ªº¦W³æ)
  43.             sh.[G2].Resize(rowA, 1).Delete Shift:=xlToLeft
  44.         End If
  45.         
  46.         '±N[G2]½Æ»s¨ì Á`ªíªºÀx¦s®æ cel
  47.         sh.[G2].Copy
  48.         cel.PasteSpecial Paste:=xlPasteValues
  49.             
  50.         '¤]½Æ»s¨ì Á`ªíªº sh1.[M12], ¥Î¥H´£¿ôºÞ²z¤H­û ³qª¾ Á{®É¥N¯Z¤H­û
  51.         sh.[G2].Copy
  52.         sh1.[M12].PasteSpecial Paste:=xlPasteValues
  53.                         
  54.         '¨Ã±N [G2] §R°£¥B¦V¤W²¾¤@®æ
  55.         sh.[G2].Delete xlUp
  56.     End If
  57.     Application.ScreenUpdating = True     '¥´¶}¿Ã¹õ¨ê·s
  58. End Sub
½Æ»s¥N½X
  1. '³B²zÂ÷¾¤H­û°Æµ{¦¡
  2. Sub ³B²zÂ÷¾¤H­û(ByVal name1 As String)
  3.     Dim sh, sh1 As Worksheet
  4.     Dim r1, rowA, col1 As Integer
  5.     Dim rng As Range, str1 As String
  6.    
  7.     Set sh1 = Sheets("Á`ªí")
  8.     Set sh = Sheets(name1)
  9.     Application.ScreenUpdating = False       'Ãö³¬¿Ã¹õ¨ê·s
  10.    
  11.     sh.[A:A].Borders.LineStyle = 0
  12.    
  13.     '//////////////////////
  14.     '¥H¤U§R°£ ÄæA ªº Â÷¾¤H­û¦W³æ
  15.     '¨ú±o ÄæA ³Ì¤U­±«DªÅ¥Õ®æ ªº¦C¸¹
  16.     rowA = sh.[A2].End(xlDown).Row + 20
  17.    
  18.     '­«·s©w¸q match ±ý·j´Mªº½d³ò
  19.     ActiveWorkbook.Names("x").Delete
  20.     ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=" & name1 & "!R2C1:R" & rowA & "C1"
  21.    
  22.     '­Y Match ¦¨¥\, «h sh1.[N8] ¬O¥Ø¼Ðªº¦C¸¹
  23.     If Application.IsNumber(sh1.[N8]) Then
  24.    
  25.         '§R°£ ·j´M¥Ø¼Ð(Â÷¾¤H­û¦W³æ), ¨Ã¦V¤W²¾¤@®æ
  26.         sh.Cells(sh1.[N8], 1).Delete Shift:=xlUp
  27.         
  28.         '//////////////////////
  29.         '¥H¤U§R°£ ÄæG¡BÄæH... ªº Â÷¾¤H­û¦W³æ
  30.         col1 = 7
  31.         Do
  32.             If sh.Cells(2, col1) <> "" Then
  33.                      
  34.                 If Application.IsNumber(sh1.[N8]) Then
  35.                     sh.Cells(sh1.[N8], col1).Delete Shift:=xlUp
  36.                 End If
  37.             End If
  38.             col1 = col1 + 1
  39.         Loop Until sh.Cells(2, col1) = ""
  40.     Else
  41.         MsgBox "§ä¤£¨ì¡i" & sh1.[M8] & "¡j" & Chr(10) _
  42.              & "½Ð¬d©ú¦A°µ!!", vbExclamation
  43.     End If
  44. End Sub
½Æ»s¥N½X
B¡B³B²z·s¶i¤H­û
vba Code ¦p¤U¡G
  1. '³B²z·s¶i¤H­û
  2. Sub ³B²z·s¶i¤H­û(ByVal name1 As String)
  3.     Dim sh, sh1 As Worksheet
  4.     Dim c1, rowA, col1 As Integer
  5.     Dim rng As Range, str1, «e«á As String
  6.    
  7.     Set sh1 = Sheets("Á`ªí")
  8.     Set sh = Sheets(name1)
  9.    
  10.     Application.ScreenUpdating = False       'Ãö³¬¿Ã¹õ¨ê·s
  11.    
  12.     '²M°£®æ½u, ¥H§K .End »~§P
  13.     sh.[A:A].Borders.LineStyle = 0
  14.     sh.[2:2].Borders.LineStyle = 0

  15.     «e«á = sh1.[O21]
  16.    
  17.     col1 = sh.[IV2].End(xlToLeft).Column
  18.     If col1 < 7 Then col1 = 7
  19.    
  20.     If «e«á = "³Ì«e­±" Then
  21.    
  22.         '¥Î´¡¤Jªº¤è¦¡, ±N·s¶i¤H­û, ´¡¤J sh.[A2]
  23.         sh1.[M18].Copy: sh.[A2].Insert Shift:=xlDown
  24.             
  25.         For c1 = 7 To col1
  26.             sh1.[M18].Copy: sh.Cells(2, c1).Insert Shift:=xlDown
  27.         Next
  28.         
  29.     Else
  30.         '±N ·s¶i¤H­û ©ñ¨ì ¦UÄæ ªº³Ì¤U­±
  31.         rowA = sh.[A2].End(xlDown).Row + 1
  32.         sh.Cells(rowA, 1) = sh1.[M18]
  33.         
  34.         For c1 = 7 To col1
  35.             rowA = sh.Cells(2, c1).End(xlDown).Row + 1
  36.             sh.Cells(rowA, c1) = sh1.[M18]
  37.         Next
  38.         
  39.     End If
  40.     Application.ScreenUpdating = True        '¥´¶}¿Ã¹õ¨ê·s
  41. End Sub
½Æ»s¥N½X
C¡B³B²zÁ{®É¥N¯Z¤H­û
vba Code ¦p¤U¡G
  1. '³B²zÁ{®É¥N¯Z
  2. Private Sub CommandButton1_Click()
  3.     Dim sh As Object, rng1, cel As Range
  4.     Dim rowA As Integer
  5.     Dim sh1 As Worksheet
  6.    
  7.     Set sh1 = Sheets("Á`ªí")
  8.    
  9.     Application.ScreenUpdating = False          'Ãö³¬¿Ã¹õ¨ê·s
  10.    
  11.     Set rng1 = sh1.Cells(sh1.[P30] * 20 - 16, 1).Resize(18, 7)
  12.    
  13.     '¦b·í¤ë­È¶Ôªí¤W, ¬d§ä Â÷¾¤H­û ¦W³æ, ¨Ã¶Çµ¹ cel
  14.     Set cel = rng1.Find(What:=sh1.[M34], LookIn:=xlValues, _
  15.         LookAt:=xlWhole)
  16.         
  17.     '¦pªG·í¤ë­È¶Ôªí¤W, ¦³§ä¨ì Â÷¾¤H­û ¦W³æ
  18.     If Not cel Is Nothing Then
  19.    
  20.         If cel.Offset(-2, 0).Font.ColorIndex = 1 Then
  21.             Set sh = Sheets("¥­¤é")
  22.         Else
  23.             Set sh = Sheets("°²¤é")
  24.         End If
  25.         
  26.         '¦pªG [G2] ¤Î [H2] §¡¬°ªÅ¥Õ, ªí¥Ü¤wµL¼È¦s¦W³æ¥i¥Î
  27.         If sh.[G2] = "" And sh.[H2] = "" Then
  28.             MsgBox "µL¼È¦s¦W³æ¥i¥Î!!", vbExclamation
  29.             Exit Sub
  30.         End If
  31.         
  32.         '­Y [G2] ¬°ªÅ¥Õ®æ(«h ÄæG ¬°ªÅ¥ÕÄæ), ¦Ó [H2] ¤£¬OªÅ¥Õ®æ, «h
  33.         If sh.[G2] = "" And sh.[H2] <> "" Then
  34.                         
  35.             '§R°£ ÄæG, ¨Ã¦V¥ª²¾(¨ú±o ÄæH ªº¦W³æ)
  36.             sh.[G2].Resize(rowA, 1).Delete Shift:=xlToLeft
  37.         End If
  38.         
  39.         '±N[G2]½Æ»s¨ì Á`ªíªºÀx¦s®æ cel
  40.         sh.[G2].Copy
  41.         cel.PasteSpecial Paste:=xlPasteValues
  42.             
  43.         '¤]½Æ»s¨ì Á`ªíªº sh1.[M12], ¥Î¥H´£¿ôºÞ²z¤H­û ³qª¾ Á{®É¥N¯Z¤H­û
  44.         sh.[G2].Copy
  45.         sh1.[M37].PasteSpecial Paste:=xlPasteValues
  46.                         
  47.         '¨Ã±N [G2] §R°£¥B¦V¤W²¾¤@®æ
  48.         sh.[G2].Delete xlUp
  49.     Else
  50.         MsgBox "" & [P30] & "¤ë¥÷­È¯Zªí¤W, ¬dµL¡i" & [M34] & "¡j¦¹¤H," & Chr(10) & Chr(10) _
  51.                 & "½Ð¬d©ú¦AÄ~Äò!!", vbExclamation
  52.     End If
  53.     Application.ScreenUpdating = True     '¥´¶}¿Ã¹õ¨ê·s
  54. End Sub
½Æ»s¥N½X
(¥¼§¹)

TOP

¦^´_ 5# yen956
³B²zÂ÷¾¤H­û°Æµ{¦¡
­×¥¿¦p¤U¡G
'³B²zÂ÷¾¤H­û°Æµ{¦¡
Sub ³B²zÂ÷¾¤H­û(ByVal name1 As String)
    Dim sh, sh1 As Worksheet
    Dim r1, rowA, col1 As Integer
    Dim rng As Range, str1 As String
   
    Set sh1 = Sheets("Á`ªí")
    Set sh = Sheets(name1)
'    Application.ScreenUpdating = False       'Ãö³¬¿Ã¹õ¨ê·s
   
    sh.[A:A].Borders.LineStyle = 0
   
    '//////////////////////
    '¥H¤U§R°£ ÄæA ªº Â÷¾¤H­û¦W³æ
    '¨ú±o ÄæA ³Ì¤U­±«DªÅ¥Õ®æ ªº¦C¸¹
    rowA = sh.[A2].End(xlDown).Row + 20
   
    '­«·s©w¸q match ±ý·j´Mªº½d³ò
    ActiveWorkbook.Names("x").Delete
    ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=" & name1 & "!R2C1:R" & rowA & "C1"
   
    '­Y Match ¦¨¥\, «h sh1.[N8] ¬O¥Ø¼Ðªº¦C¸¹
    If Application.IsNumber(sh1.[N8]) Then
   
        '§R°£ ·j´M¥Ø¼Ð(Â÷¾¤H­û¦W³æ), ¨Ã¦V¤W²¾¤@®æ
        sh.Cells(sh1.[N8], 1).Delete Shift:=xlUp
        
        '//////////////////////
        '¥H¤U§R°£ ÄæG¡BÄæH... ªº Â÷¾¤H­û¦W³æ
        col1 = 7
        Do
            If sh.Cells(2, col1) <> "" Then
                '­«·s©w¸q match ±ý·j´Mªº½d³ò
                ActiveWorkbook.Names("x").Delete
                ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=" & name1 & "!R2C" & col1 & ":R" & rowA & "C" & col1 & ""

                     
                If Application.IsNumber(sh1.[N8]) Then
                    sh.Cells(sh1.[N8], col1).Delete Shift:=xlUp
                End If
            End If
            col1 = col1 + 1
        Loop Until sh.Cells(2, col1) = ""
    End If
End Sub

TOP

¦^´_ 3# h60327
¦p¦ó»s§@¸õ¸¹½ü­Èªí(§¹)
¥|¡B³Ì«áÁÙ¦³¤@­Ó°ÝÃD­n³B²z,
¨º´N¬O¡i³sÄò°²¤é¡j­n¤£­n³s±Æ¦P¤@¤H?
¦pªG¡i³sÄò°²¤é­n³s±Æ¦P¤@¤H¡j,
«h­n¦A¼W¥[¤@±i¤u§@ªí¡÷¡i¤é´Áªí¡j,
§Y±N­ì¤ë¾äªí(Á`ªí), Âà¿ý¦¨¡i¤é¬W¡j, ¥H¤è«KVBA¦s¨ú,
¡i«Ø¥ß¤é´Áªí¡jªºVBA Code ¦p¤U¡G
  1. '«Ø¥ß¤é´Áªí
  2. '±N¡iÁ`ªí¡jªº ¤ë¾ä Âà´«¦¨¡i¤é´Áªí¡jªº¤é¬W
  3. Private Sub CommandButton1_Click()
  4.     Dim sh1, sh2 As Worksheet
  5.     Dim ¦~, ¤ë, i, j, k As Integer
  6.    
  7.     Set sh1 = Sheets("Á`ªí")
  8.     Set sh2 = Sheets("¤é´Áªí")
  9.    
  10.     Application.ScreenUpdating = False   'Ãö³¬¿Ã¹õ¨ê·s
  11.    
  12.     '±q¡iÁ`ªí¡jªº¡i¤ë¾äªí¡j¨ú±o ¦~(¦è¤¸), ¨Ã¦s¤J sh2.[A2]
  13.     sh2.[A2] = "=MID(Á`ªí!A2,3,4)"
  14.    
  15.     k = 1
  16.     For ¤ë = 1 To 12
  17.         
  18.         '¤ë¾äªí¤W, ¨C¤ë¦³ 6 ¶g(¥]¬AªÅ¥Õ®æ)
  19.         For i = 1 To 6
  20.         
  21.            '¤ë¾äªí¤W, ¨C¶g¦³ 7 ¤Ñ
  22.             For j = 1 To 7
  23.             
  24.                 '¦pªG¤ë¾äªí¤W¬OªÅ¥Õ®æ, ´«¤U¤@®æ
  25.                 If sh1.Cells(¤ë * 20 + i * 3 - 19, j) <> "" Then
  26.                
  27.                     k = k + 1
  28.                
  29.                     sh2.Cells(k, 2) = ¤ë
  30.                     sh1.Cells(¤ë * 20 + i * 3 - 19, j).Copy sh2.Cells(k, 3)
  31.                     sh1.Cells(¤ë * 20 + i * 3 - 18, j).Copy sh2.Cells(k, 4)
  32.                     sh2.Cells(k, 5) = DateSerial(sh2.[A2], ¤ë, sh2.Cells(k, 3))
  33.                     sh2.Cells(k, 6) = sh2.Cells(k, 5)
  34.                     
  35.                 End If
  36.             Next
  37.         Next
  38.     Next
  39.     sh2.[A1].Resize(367, 7).Font.Size = 12
  40.     sh2.[A1].Resize(367, 7).Borders.LineStyle = 0
  41.     Application.ScreenUpdating = True     '¥´¶}¿Ã¹õ¨ê·s
  42. End Sub
½Æ»s¥N½X
¦p¤U¹Ï¡G

³Ì«á¦A¥[¤W
A¡B±Æ½ü­Èªí(³sÄò°²¤é³s±Æ¦P¤@¤H)
vba Code ¦p¤U¡G
  1. '°Æµ{¦¡
  2. Sub ½Æ»s¦W³æ¨ì¤é´Áªí(ByVal name1 As String, ByVal k As Integer)
  3.     Dim sh, sh2 As Object
  4.     Set sh = Sheets(name1)
  5.     Set sh2 = Sheets("¤é´Áªí")
  6.    
  7.     '­Y [G2] ¬°ªÅ¥Õ®æ(«h ÄæG ¬°ªÅ¥ÕÄæ), ¦Ó [H2] ¤£¬OªÅ¥Õ®æ, «h
  8.     If sh.[G2] = "" Then
  9.             
  10.         '§R°£ ÄæG, ¨Ã¦V¥ª²¾(¨ú±o ÄæH ªº¦W³æ)
  11.         sh.[G2].Resize(row3, 1).Delete Shift:=xlToLeft
  12.     End If
  13.             
  14.     '±N[G2]½Æ»s¨ì ¤é´Áªí
  15.     sh.[G2].Copy
  16.     sh2.Cells(k, 7).PasteSpecial Paste:=xlPasteValues
  17.             
  18.     '¨Ã±N [G2] §R°£¥B¦V¤W²¾¤@®æ
  19.     sh.[G2].Delete xlUp
  20. End Sub

  21. '°Æµ{¦¡
  22. Sub ±q¤é´Áªí½Æ»s¦W³æ¨ìÁ`ªí()
  23.     Dim sh1, sh2 As Object
  24.     Dim i, j, k As Integer
  25.     Dim cel As Range
  26.    
  27.     Set sh1 = Sheets("Á`ªí")
  28.     Set sh2 = Sheets("¤é´Áªí")
  29.    
  30.     '¡i¤é´Áªí¡j¤¤, ±ý½Æ»s¨ì¡iÁ`ªí¡jªº¦W³æ ªº ©l¦C¸¹
  31.     k = sh2.[J14]
  32.    
  33.     '±q ¤é´Áªí ½Æ»s¨ì Á`ªí
  34.     For i = 1 To 6
  35.         For j = 1 To 7
  36.         
  37.             Set cel = sh1.Cells(sh2.[J13] * 20 + i * 3 - 19, j)
  38.             
  39.             '­Y¤é´Á = "", «h´«¤U¤@­Ó
  40.             If cel <> "" Then
  41.                
  42.                 cel.Offset(2, 0) = sh2.Cells(k, 7)
  43.             End If
  44.             
  45.             k = k + 1
  46.         Next
  47.     Next i
  48. End Sub
½Æ»s¥N½X
  1. '±Æ½ü­Èªí(³sÄò°²¤é³s±Æ¦P¤@¤H)
  2. Private Sub CommandButton2_Click()
  3.     Dim sh1, sh2, sh3, sh4 As Object
  4.     Dim i, j, k, row3, row4 As Integer
  5.     Dim cel As Range
  6.    
  7.     Set sh1 = Sheets("Á`ªí")
  8.     Set sh2 = Sheets("¤é´Áªí")
  9.     Set sh3 = Sheets("¥­¤é")
  10.     Set sh4 = Sheets("°²¤é")
  11.    
  12.     '­Y [G2] ¤Î [H2] ¬Ò¬°ªÅ¥Õ®æ, «h
  13.     If sh4.[G2] = "" And sh4.[H2] = "" Then
  14.         MsgBox "¤wµL¦W³æ¥i¥Î", vbExclamation
  15.         Exit Sub
  16.     End If
  17.    
  18.     Application.ScreenUpdating = False      'Ãö³¬¿Ã¹õ¨ê·s
  19.    
  20.     row3 = sh3.[A2].End(xlDown).Row
  21.     row4 = sh4.[A2].End(xlDown).Row
  22.    
  23.     'sh2.[J14] ª½±µ«ü¦V¡i¤é´Áªí¡j«ü©w¤ë¥÷ªº ¶}©l¦C¸¹
  24.     sh2.[J14] = "=MATCH(J13,B2:B367,0) + 1"
  25.     k = sh2.[J14]
  26.    
  27.     Do
  28.         
  29.         '³B²z¥­¤é
  30.         If sh2.Cells(k, 3).Font.ColorIndex = 1 Then
  31.         
  32.             ½Æ»s¦W³æ¨ì¤é´Áªí "¥­¤é", k
  33.             
  34.         '³B²z°²¤é
  35.         Else
  36.         
  37.             '¦pªG «e¤@¤Ñ ¤]¬O °²¤é, «h±q«e¤@¤Ñªº¦W³æ ½Æ»s¦W³æ
  38.             If sh2.Cells(k - 1, 3).Font.ColorIndex = 3 _
  39.                    Or sh2.Cells(k - 1, 3).Font.ColorIndex = 5 Then
  40.             
  41.                 If sh2.Cells(k - 1, 7) <> "" Then
  42.                     sh2.Cells(k, 7) = sh2.Cells(k - 1, 7)
  43.                     
  44.                 '¦ý, ¦pªG «e¤@¤Ñªº ¦W³æ ¬OªÅ¥Õ, «h¦Û "°²¤é" ªí¤¤, ½Æ»s¦W³æ
  45.                 Else
  46.                     ½Æ»s¦W³æ¨ì¤é´Áªí "°²¤é", k
  47.                 End If
  48.                
  49.             '§_«h, ¦Û "°²¤é" ªí¤¤, ½Æ»s¦W³æ
  50.             Else
  51.                 ½Æ»s¦W³æ¨ì¤é´Áªí "°²¤é", k
  52.             End If
  53.         End If
  54.         
  55.         k = k + 1

  56.     Loop Until sh2.Cells(k, 2) > sh2.[J13]
  57.    
  58.     ±q¤é´Áªí½Æ»s¦W³æ¨ìÁ`ªí
  59.    
  60.     Application.ScreenUpdating = True          '¥´¶}¿Ã¹õ¨ê·s
  61. End Sub
½Æ»s¥N½X
B¡B±Æ½ü­Èªí(³sÄò°²¤é¤£³s±Æ¦P¤@¤H)
vba Code ¦p¤U¡G
  1. '±Æ½ü­Èªí(³sÄò°²¤é¤£³s±Æ¦P¤@¤H)
  2. Private Sub CommandButton3_Click()
  3.     Dim sh1, sh2, sh3, sh4 As Object
  4.     Dim i, j, k, row3, row4 As Integer
  5.     Dim cel As Range
  6.    
  7.     Set sh1 = Sheets("Á`ªí")
  8.     Set sh2 = Sheets("¤é´Áªí")
  9.     Set sh3 = Sheets("¥­¤é")
  10.     Set sh4 = Sheets("°²¤é")
  11.    
  12.     '­Y [G2] ¤Î [H2] ¬Ò¬°ªÅ¥Õ®æ, «h
  13.     If sh4.[G2] = "" And sh4.[H2] = "" Then
  14.         MsgBox "¤wµL¦W³æ¥i¥Î", vbExclamation
  15.         Exit Sub
  16.     End If
  17.    
  18.     Application.ScreenUpdating = False      'Ãö³¬¿Ã¹õ¨ê·s
  19.    
  20.     row3 = sh3.[A2].End(xlDown).Row
  21.     row4 = sh4.[A2].End(xlDown).Row
  22.    
  23.     'sh2.[J14] ª½±µ«ü¦V¡i¤é´Áªí¡j«ü©w¤ë¥÷ªº ¶}©l¦C¸¹
  24.     sh2.[J14] = "=MATCH(J13,B2:B367,0) + 1"
  25.     k = sh2.[J14]
  26.    
  27.     Do
  28.         
  29.         '­Y ColorIndex = 1, «h¦Û¡i¥­¤é¡jªí¤¤, ½Æ»s¦W³æ ¨ì¡i¤é´Áªí¡j
  30.         If sh2.Cells(k, 3).Font.ColorIndex = 1 Then
  31.         
  32.             ½Æ»s¦W³æ¨ì¤é´Áªí "¥­¤é", k
  33.             
  34.         '§_«h, ¦Û¡i°²¤é¡jªí¤¤, ½Æ»s¦W³æ ¨ì¡i¤é´Áªí¡j
  35.         Else
  36.         
  37.             ½Æ»s¦W³æ¨ì¤é´Áªí "°²¤é", k
  38.         End If
  39.         
  40.         k = k + 1

  41.     Loop Until sh2.Cells(k, 2) > sh2.[J13]
  42.    
  43.     ±q¤é´Áªí½Æ»s¦W³æ¨ìÁ`ªí
  44.    
  45.     Application.ScreenUpdating = True          '¥´¶}¿Ã¹õ¨ê·s
  46. End Sub
½Æ»s¥N½X
OK, ¤j¥\§i¦¨, ¥i¥H´ú¸Õ¥h¤F¡C
¤£·Q¦Û¤v°Ê¤âªºªB¤Í, ³o¸Ì¦³¤@­Ó²{¦¨ªºÀÉ®×,
¥i¤U¸ü¨Ó¸Õ¸Õ¬Ý¡G
http://www.mediafire.com/download/6ibnow9d2rk851g/%E8%B7%B3%E8%99%9F%E8%BC%AA%E5%80%BC%E8%A1%A8.7z
¶¶«KÀ°¦£´ú¸Õ, ÁÂÁÂ!!

TOP

        ÀR«ä¦Û¦b : ¥Í®ð¡A´N¬O®³§O¤Hªº¹L¿ù¨ÓÃg»@¦Û¤v¡C
ªð¦^¦Cªí ¤W¤@¥DÃD