Create new file copy template

[kannaree]

สวัสดีค่ะ อาจารย์และทุกท่าน รายละเอียดการทำระบบมีเยอะมากเปลี่ยนแปลงไปตาม requirement และมาลองทำดูแล้วไม่ประสบความสำเร็จ
ขอโทษทางเพจนะคะที่ต้องมาตั้งคำถามบ่อยๆ
รบกวนขอความช่วยเหลือจากทุกท่าด้วยค่ะ

311.png

จะเห็นว่าจากรูป Column A มีข้อมูล 3 ข้อมูล แต่ช่อง C , D มี 20 ข้อมูล
อยากคลิกปุ่ม แล้วแตกไฟล์ใหม่ ได้เป็น ไฟล์ดังรูป ดังนี้

EBV.png

WPG.png

Code: Select all

Sub Button1_Click()
Dim thisWB  As String

Dim newWB As String

    thisWB = ActiveWorkbook.Name
    
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
    
    Sheets("Sheet1").Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        
        On Error Resume Next
        
        
        ActiveSheet.ShowAllData
        
        On Error GoTo 0
    
    End If
    
    Columns("B:B").Select
    Selection.Copy
    
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
        
        If lastrow <> Rows.Count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
    
    End If
    
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
    
    Columns("A:A").Delete
    
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    
    lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
    
    For suppno = 2 To lMaxSupp
    
        Windows(thisWB).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
        
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
            
            Windows(thisWB).Activate

            Sheets("Sheet1").Select
            Cells.Select
            
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
            
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
            
            lastrow = Cells(Rows.Count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
            
            Windows(newWB).Activate
            ActiveSheet.Paste

            ActiveWorkbook.Save
            ActiveWorkbook.Close
            
        End If
    
    Next
    
    Sheets("tempsheet").Delete
    
    Sheets("Sheet1").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If
End Sub

จะต้องทำอย่างไรค่ะ

[kannaree]

test_60717.xlsx

[parakorn]

เผอิญไม่ค่อยเก่ง VBA เท่าไหร่ครับ
ลองปรับ Code เป็น

Code: Select all

Sub AddWorkSheets()
    Dim i As Long
    Dim r As Range
    On Error Resume Next
    With Worksheets("Sheet1")
        Set r = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With
    For i = 1 To r.Count
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = r.Cells(i, 1).Value
        ActiveSheet.Range("c2:d21").Select
        Selection.Value = Sheets("Sheet1").Range("c2:d21").Value
        ActiveSheet.Range("c2:c21").Select
        Selection.Offset(0, -2).Value = ActiveSheet.Name
        
    Next i
    
End Sub

ดูครับ
หรือรอท่านอื่นมาเพิ่มเติมอาจได้ Code ที่ใช้งานง่ายกว่านี้ครับ