Insert Sheet & name base on cells

[yukioh]

สะหวัดดีครับ อาจารย์

ขออนุญาตรบกวนสอบถาม VBA :

- ผมมีข้อมูลอยู่ครับ ผมต้องการ เพิ่มชีทหลาย ๆ ชีท และ ต้องการให้ชื่อชีทเป็นชื่อที่เรากำหนดไว้แล้วใน colum b หลัง
- จากที่ เพี่มชีท และ ชื้อชีท ตามที่เรากำนดแล้ว format ของชีท "Main" ยังคงเหมือนเดิม และ ให้มีขื้อของชีทนั้น ยังอยู่ ตัวอย่างเช่น sheet "yukioh" ให้มี ขื้อของ yukioh ในตะลางอย่างเดียว

ตัวอย่างไฟล์ที่แนบมา


ขอบคุณครับอาจารย์ครับ

[snasui]

ตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Sub AddWorkSheets()
    Dim r As Range, rAll As Range, H As Range
    
    On Error Resume Next
    
    ' set range data from reference cells
    With Worksheets("Main")
        Set rAll = .Range("B7", .Range("B65536").End(xlUp)).Offset(-1, 0)
        Set H = .Range("a5:n5")
    End With
      
    ' add sheet base on named cells
    For Each r In rAll
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = r.Value
        H.Copy Sheets(r.Value).Range("a1:n1")
        r.Offset(0, -1).Resize(1, 14).Copy Sheets(r.Value).Range("a2:n2")
    Next r
End Sub

[yukioh]

สวัสดีครับ อาจารย์
ผมได้ลองปลับ code แล้วครับ เป็นไปตามที่ต้องกานแล้ว

และ ผม ได้เพี่มบางส่วนเข้าไป เพื่อให้ VBA แจ้งว่า " มี sheet xxx มีอยู่แล้ว "
ผมได้ทดสอบ กด ให้VBA run แล้ว ทำงาน ถ้ากดสองครั้ง จะแจ้งเติอน "A Sheet with that name already exists"
ผมลองลบ sheet บางส่วน แต่ก็เหมือนเดีมครับ ทังที่เราลบออกไปแล้ว ยังแจ้งเติอน "A Sheet with that name already exists"

ผมอยากให้VBA ตรดว่า ถ้า sheet ไหมไม่มี หลือ ถูกลบออกไป ให้ create sheet เข้าไป และ แจ้งว่า " มี sheet xxx มีอยู่แล้ว "

รบกวนอาจารย์ด้วยครับ

[snasui]

หากต้องการทำให้ง่ายควรจะ Loop เพื่อลบทุกชีทออกให้หมด เหลือเฉพาะชีท Main แล้วค่อยใช้ Code เดิมสร้างชีทต่าง ๆ ขึ้นมาใหม่ ไม่ทราบว่าหากใช้วิธีการนี้ ติดขัดปัญหาใดครับ

[yukioh]

รบกวนอาจารย์ แนะนำ Code ให้ด้วยครับ

[snasui]

เขียน Loop ชีททั้งหมดออกมาให้ได้ก่อนแล้วค่อยถามกันต่อครับ

[yukioh]

ประมารนี้ใช้ไหมครับ
รบกวนอาจารย์ แนะนำให้ด้วยครับ

Code: Select all

Sub Deleteshts()

Dim RowNo As Long, LR As Long
    
With Sheets("main")
       LR = .Cells(.Rows.Count, "B").End(xlUp).Offset(-1, 0).Row
    For RowNo = 6 To LR
   
       ' On Error Resume Next
       ' initialize row name in table for delete shts
        Application.DisplayAlerts = False
        For Each WS In ActiveWorkbook.Worksheets
            If WS.Name <> Sheets("MAIN").Cells(RowNo, "B") Then
                Else
            WS.Visible = xlSheetVisible
            WS.Delete
            End If
        Next WS
        Application.DisplayAlerts = True
    Next

Exit Sub
End With

End Sub

[snasui]

ดูตัวอย่าง Code การ Loop เพื่อลบชีทต่าง ๆ ออกก่อน แล้วค่อยสร้างใหม่ตามด้านล่างครับ

Code: Select all

Sub AddWorkSheets()
    Dim r As Range, rAll As Range, H As Range, F As Range, WS As Worksheet
    Dim RowNo As Long, LR As Long
    
    ' On Error Resume Next
    Application.DisplayAlerts = False
    
    ' initialize row name in table
    For Each WS In ActiveWorkbook.Worksheets
        If WS.Name <> "Main" Then
            WS.Delete
        End If
    Next
    
    ' set range data from reference cells
    With Worksheets("Main")
        Set rAll = .Range("B11", .Range("B65536").End(xlUp)).Offset(-1, 0)
        Set H = .Range("A1:N5") 'set header data
        Set F = [TFD] '.Offset(-1, 0) 'set footer data
    End With
    
    ' add sheet base on named cells
    For Each r In rAll
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = r.Value
        H.Copy Sheets(r.Value).Range("a1:u1")
        r.Offset(0, -1).Resize(1, 21).Copy Sheets(r.Value).Range("A65536").End(xlUp).Offset(1, 0)  '.Range("a2:n2")
        F.Copy Sheets(r.Value).Range("A12")
    Next r
    
    Application.DisplayAlerts = True
    
End Su

[yukioh]

ขอบคุณครับอาจารย์ครับ สำหรับความ กะรุนา

[yukioh]

สวัสดีครับ อาจารย์
พอผมลองทดสอบ run code ทังหมด และ ตรวจเพิ่มเติม, มีปัญหาเพี่มอีก อยากจะรบกวนอาจารย์ครับ
คิอ ผมพิมชื้อในตะลางว่า Name ว่า " Bb " 2 แถว, และทดสอบดู ปลากดว่า ใน sheet "Bb" ชื้อใน ตาราง แยกกันคนละแถว และ มี่ "name...Date" มาขั้นละหว่าง ชื้อ "Bb" สองครั้ง

ชื้งผมค้องกาน ถ้าทีชื้อช้ำกันอยู ให้อยู่ในให้ sheet เดียวกันเรียงลงมา ดั่งไฟล์แนบตัวอย่าง

รบกวนอาจารย์ด้วยครับ

[snasui]

ปัญหาคือคุณลำดับการทำงานของโปรแกรมหรือแจ้งความต้องการมาไม่ครบถ้วน

สำหรับปัญหานี้เป็นการทำรายงานจากฐานข้อมูลที่เตรียมไว้ล่วงหน้าโดย

1. สร้างชีทขึ้นมาใหม่ตามค่าในคอลัมน์ B ของชีท Main
2. หลังจากสร้างชีทขึ้นมาใหม่แล้ว หากค่าในคอลัมน์ B ของชีท Main ตรงกับชื่อของชีทใดให้ Copy ค่าทั้งบรรทัดไปวางในชีทที่สร้างขึ้นใหม่ หากมีหลายรายการให้วางต่อเนื่องกันไปด้านล่าง

ดูตัวอย่าง Code ตามด้านล่างครับ

Code: Select all

Sub AddWorkSheets()
    Dim r As Range, rall As Range
    Dim H As Range, H1 As Range, F As Range
    Dim cl As New Collection, sh As Worksheet
    
    ' set range data from reference cells
    With Worksheets("Main")
        Set rall = .Range("B7", .Range("B65536").End(xlUp)).Offset(-1, 0)
        Set H = .Range("A1:N5") 'set header data
        Set H1 = [Ttl] ' Set Total row
        Set F = [TFD] 'set footer data "name & Date"
    End With
    
    On Error Resume Next
    For Each r In rall
        cl.Add r, r
    Next r
    On Error GoTo 0
    
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If sh.Name <> "Main" Then
            sh.Delete
        End If
    Next sh
    Application.DisplayAlerts = True
    
    For Each Item In cl
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = Item
    Next Item
    
    ' add sheet base on named cells
    For Each r In rall
        If Sheets(r.Value).Range("a1") = "" Then
            H.Copy Sheets(r.Value).Range("a1:u1") 'head table
        End If
        r.Offset(0, -1).Resize(1, 21).Copy Sheets(r.Value).Range("A65536").End(xlUp).Offset(1, 0)  'name
    Next r
    
    For Each sh In Worksheets
        If sh.Name <> "Main" Then
            H1.Copy sh.Range("A65536").End(xlUp).Offset(1, 0) ' Total
            F.Copy sh.Range("A65536").End(xlUp).Offset(2, 0) 'name & Date
        End If
    Next sh
    
End Sub

[yukioh]

ขอบคุณครับอาจารย์ครับ