| ©«¤l129 ¥DÃD25 ºëµØ0 ¿n¤À159 ÂI¦W0  §@·~¨t²Îwin7 ³nÅ骩¥»office2010 ¾\ŪÅv20 ©Ê§O¨k µù¥U®É¶¡2011-12-24 ³Ì«áµn¿ý2022-12-12 
 | 
                
| ¦^´_ 14# iceandy6150½Æ»s¥N½XOption Explicit   '¥²¶·¸m©ó¼Ò²Õ³»ºÝ ±j¨î«Å§iÅܼÆ
Private Sub CommandButton1_Click()
    Dim Sh As Worksheet, i As Integer, ii As Integer, r As Integer, Ar 'Dim «Å§iÅܼÆ
    Dim k As Integer
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Sh In Sheets
        If Sh.Name <> "¤u§@ªí1" And Sh.Name <> "¤u§@ªí2" And Sh.Name <> "ªí®æ½d¥»" Then Sh.Delete
        '¬¡¶Ã¯¥u¯d ¤u§@ªí1¡G¬O¿é¤J°Ï,¤u§@ªí2¡G¬O¾ú¥v°O¿ý ,"ªí®æ½d¥»"
    Next
    
    With Sheets("¤u§@ªí2")
        If .UsedRange.Rows.Count = 1 Then              '¨S¦³¾ú¥v¬ö¿ý
           '.UsedRange.Rows.Count = 1
             Sheets("¤u§@ªí1").UsedRange.Copy            '½Æ»s(§t¼ÐÀY)
            .Range("A1").PasteSpecial xlPasteValues
            
        Else
            Sheets("¤u§@ªí1").UsedRange.Offset(1).Copy  '½Æ»s(¤£§t¼ÐÀY)
            Sheets("¤u§@ªí2").Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
            'Offset(3) :ªÅ2¦C->²Ä3¦C¶K¤W
           
        End If
        
        
    End With
    
    
    With Sheets("¤u§@ªí1")
    
    .UsedRange.Range("E:E").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
    '¶i¶¥¿z¿ï EÄæ ¤£«½Æ¸ê®Æ¨ì¤u§@ªí³Ì¥kÄæ ***¨ú±oÃþ§Oªº¤ÀÃþ***
    'AdvancedFilter:¶i¶¥¿z¿ï
    'xlFilterCopy:¶i¶¥¿z¿ïªº¸ê®ÆÅã¥Ü¦b¨ä¥L¦a¤è
    '.Cells(1, .Columns.Count) ->¤u§@ªíªº³Ì¥kÄæ²Ä1ÓÀx¦s®æ->¶i¶¥¿z¿ïªº¸ê®ÆÅã¥Üªº¦a¤è
        
        i = 2
        Do While .Cells(i, .Columns.Count) <> ""                  '¤u§@ªí³Ì¥kÄæªºÀx¦s®æ <>""
            .Range("A:E").AutoFilter 5, .Cells(i, .Columns.Count)          'AutoFilter: ¦Û°Ê¿z¿ï ,²Ä5Äæ(Ãþ§O)ªº·Ç«h¬° .Cells(i, .Columns.Count)
            Sheets("ªí®æ½d¥»").Copy , Sheets(Sheets.Count)
            Set Sh = ActiveSheet
            Sh.[a1] = .Cells(i, .Columns.Count) & "¤ä¥Xªí"
            Sh.Name = .Cells(i, .Columns.Count)
            r = 5
            For Each Ar In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows  '¿z¿ï¥Xªº¸ê®Æ¦C
                If r = 17 Then
                    r = 6
                    Sh.Copy , Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                    Sh.Range("A6:E16") = ""
                End If
                Sh.Cells(r, "a").Resize(, Ar.Columns.Count) = Ar.Value   'Index(AR, ii) :Ū¨ú°}¦C
                r = r + 1
           Next
           i = i + 1
        Loop
        
        k = 1
        Do While .Cells(k, .Columns.Count) <> ""
        .Cells(k, .Columns.Count) = ""
        k = k + 1
        Loop
        
        '.Cells(1, .Columns.Count).CurrentRegion = ""
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
    Me.Activate
End Sub
 §Ú¸Õ¥X¨Ó¤F¡A¶K¤W¥N½X¤ÎªþÀÉ
 ·PÁÂG¤j¼ö¤ß±Ð¾Ç
 
 ¥un¦b¤u§@ªí1¡A¿é¤J¸ê®Æ¡A«ö¤U«ö¶s¡A´N¯à¦Û°Ê²£¥Í¬Û¹ïÀ³ªº¤u§@ªí
 ¨Ã±N¸ê®Æ¤ÀÃþ¦n©ñ¨ì¬Û¹ïÀ³ªº¤u§@ªí¤º¡A¥i¨Ñ¨Ï¥ÎªÌª½±µ¦C¦L¥X¨Ó
 ¦Ó¨C¦¸°Ê§@¤]·|°O¿ý¦b¤u§@ªí2¤¤¡A·í§@¾ú¥v¬ö¿ý
 | 
 
 
ttt.rar
(19.09 KB)
 
 §¹¦¨ÀÉ |