Snasui Excel Forum

Code: Select all

Sub CreateShs()
    Dim r As Range, d As Object, S As Worksheet
    Set d = CreateObject("scripting.dictionary")
    
    Application.DisplayAlerts = False
    For Each S In Worksheets
        If S.Name <> Sheets(1).Name And S.Name <> Sheets(2).Name Then              'ลบทุก sheet ยกเว้น sheet1 & sheet2
            S.Delete
        End If
    Next S
     
    With Sheets(1)
                For Each r In .Range("b8", .Range("b" & .Rows.count).End(xlUp))
                             If Not d.exists(r.Value) Then
                                d.Add r.Value, r.Value
                                Set S = Worksheets.Add(after:=Worksheets(Sheets.count))
                                S.Name = r.Value
                                S.Range("AZ1").Value = "CC"
                                S.Range("AZ2").Value = r.Value
                                .UsedRange.AdvancedFilter xlFilterCopy, _
                                   S.Range("AZ1:AZ2"), S.Range("A7")
                             S.Range("AZ1:AZ2").Clear

                              End If
                Next r
       End With
             
    
    Sheets("Sheet1").Select
    Range("b8").Select
    Selection.AutoFilter
    Selection.End(xlDown).Select
    
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
    
   End Sub

Code: Select all

Sub CreateShs()
    Dim r As Range, d As Object, S As Worksheet
    Set d = CreateObject("scripting.dictionary")
    
    Application.DisplayAlerts = False
    For Each S In Worksheets
        If S.Name <> Sheets(1).Name And S.Name <> Sheets(2).Name Then              'ลบทุก sheet ยกเว้น sheet1 & sheet2
            S.Delete
        End If
    Next S
     
    With Sheets(1)
                For Each r In .Range("b8", .Range("b" & .Rows.count).End(xlUp))
                             If Not d.exists(r.Value) Then
                                d.Add r.Value, r.Value
                                Set S = Worksheets.Add(after:=Worksheets(Sheets.count))
                                S.Name = r.Value

                                S.Range("AZ7").Value = "CC"                            'row filter ให้ชื่อ cc วางไว้ที่ AZ7
                                S.Range("AZ8").Value = r.Value                         'data ที่ loop ได้เก็บไว้ที่ AZ8
                                .UsedRange.AdvancedFilter xlFilterCopy, _
                                   S.Range("AZ7:AZ8"), S.Range("a7")                'Copy data จาก filter ให้ CC วาง row 7 และ data วาง row 8 ลงไป
                                S.Range("AZ7:AZ8").Clear                                 'Clear filter

                                Sheets("Sheet1").Select                                     'ไป sheet แรก
                                Rows("1:6").Copy                                            'copy row 1-6
                                S.Paste                                                           'วางใน sheet สุดท้ายที่สร้าง row 1-6

                              End If
                Next r
       End With
             
    
    Sheets("Sheet1").Select
    Range("b8").Select
    Selection.AutoFilter
    Selection.End(xlDown).Select
    
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation
    
   End Sub

Code: Select all

Sub CreateShs()
    Dim r As Range, d As Object, S As Worksheet
    Set d = CreateObject("scripting.dictionary")
    
    Application.DisplayAlerts = False
    For Each S In Worksheets
        If S.Name <> Sheets(1).Name And S.Name <> Sheets(2).Name Then              'ลบทุก sheet ยกเว้น sheet1 & sheet2
            S.Delete
        End If
    Next S
    
    With Sheets(1)
        For Each r In .Range("b8", .Range("b" & .Rows.Count).End(xlUp))
            If Not d.exists(r.Value) Then
                d.Add r.Value, r.Value
                Set S = Worksheets.Add(after:=Worksheets(Sheets.Count))
                S.Name = r.Value
                
                S.Range("AZ7").Value = "CC"                            'row filter ให้ชื่อ cc วางไว้ที่ AZ7
                S.Range("AZ8").Value = r.Value                         'data ที่ loop ได้เก็บไว้ที่ AZ8
                .UsedRange.Offset(6, 0).AdvancedFilter xlFilterCopy, _
                    S.Range("AZ7:AZ8"), S.Range("a7")                'Copy data จาก filter ให้ CC วาง row 7 และ data วาง row 8 ลงไป
                S.Range("AZ7:AZ8").Clear                                 'Clear filter
                .Range("a1:n6").Copy S.Range("a1")
'                Sheets("Sheet1").Select                                     'ไป sheet แรก
'                Rows("1:6").Copy                                            'copy row 1-6
'                S.Paste                                                           'วางใน sheet สุดท้ายที่สร้าง row 1-6
            
            End If
        Next r
    End With
    
    Application.DisplayAlerts = True
    MsgBox "Finish", vbInformation

End Sub