ใส่รหัสก่อนเปิดซีทดูข้อมูล

[joo]

ทดลอง Run code แล้วสามารถเปลี่ยน Password ได้แล้วครับ ขอบคุณครับ
ถามเพิ่มอีกหน่อยครับ ถ้าต้องการให้แต่ละหน่วยงานสามารถเปิดไฟล์นี้พร้อมๆ กันได้ โดยสามารถเข้ามาบันทึกแก้ไขข้อมูลข้อมูลได้ โดยใส่รหัสตามชื่อซีทของหน่วยงานต้องไปตั้งค่าตรงไหนครับ เพราะโดยปกติถ้าเปิดไฟล์นี้อยู่ก่อนแล้วเครื่องที่เปิดไฟล์นี้ที่หลังก็จะอ่านได้อย่างเดียวไม่สามารถบันทึกลงไฟล์เดิมได้

[snasui]

ต้อง Share File ไว้ครับถึงจะทำเช่นนั้นได้ วิธีการ Share ทำตามด้านล่างครับ

1. เข้าเมนู Tools
2. คลิก Share Workbook
3. แถบ Editing ทำเครื่องหมายที่ Allow change by more than one user at the same time. This also allows workbook merging
4. คลิก OK

[joo]

1. ทดลองแล้วตามที่แนะนำทำได้แล้วครับ
2.ถ้าซีท “Report” มีการป้องกันแผ่นงานไว้ เมื่อคลิกที่ปุ่ม Copy ข้อมูลให้ระบบถามหารหัสผ่านก่อนที่จะทำการ Copy ข้อมูล ถ้าหากไม่กรอกรหัสหรือกรอรหัสผิดก็ให้ยกเลิกการ Copy ทั้งหมด ที่ทำได้ตอนนี้คือผมแทรกโค๊ด
ActiveSheet.Unprotect ก่อนบรรทัด
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial xlPasteValues
Worksheets("Report").Range("L7:L16").Copy
ผลปรากฏว่าถ้าใส่รหัสถูก Copy ข้อมูลได้แต่ถ้าใส่ผิดหรือไม่ใส่เลยก็จะ Bug ที่บรรทัดนี้ครับ ActiveSheet.Unprotect
ช่วยดูโค๊ดให้หน่อยครับ

[snasui]

การ Share File เป็นการกำหนดให้สามารถใช้งานพร้อมกันได้หลาย ๆ คนสำหรับไฟล์นั้น ๆ ซึ่งเท่าที่เปิดดูไฟล์นั้นกำหนดเป็น Share ไว้แล้ว แต่ที่เปิดมาเป็นอ่านได้อย่างเดียวผมเข้าใจว่าเกิดจากการ Share Folder ที่เก็บ File นี้ครับ ซึ่งจำเป็นต้อง Share แบบให้แก้ไขไฟล์ได้ด้วย ดูตัวอย่างตามภาพด้านล่างครับ

สำหรับปลดการป้องกัน สามารถเพิ่ม Code ให้กรอก Password ผ่าน InputBox อีกทีตามด้านล่าง

Code: Select all

Do
    Pswd = InputBox("Please enter Password.")
Loop Until Pswd = "123"

    ActiveSheet.Unprotect Password:=Pswd

จะได้เป็น

Code: Select all

Sub CopyNewSheet()
Dim i As Integer
Dim strNameSheet As String
Dim Pswd As String
'Do
strNameSheet = InputBox("Please enter sheet name.")
   If strNameSheet = "" Then
       Exit Sub
    End If
'Loop Until strNameSheet <> ""

For i = 1 To Worksheets.Count
        If UCase(Worksheets(i).Name) = UCase(strNameSheet) Then
           MsgBox "Please try again"
           Exit Sub
        End If
Next

    Worksheets("Report").Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = strNameSheet
    
'  If Password = "" Then
'       Exit Sub
'   End If

Do
    Pswd = InputBox("Please enter Password.")
Loop Until Pswd = "123"

    ActiveSheet.Unprotect Password:=Pswd
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial xlPasteValues
    Worksheets("Report").Range("L7:L16").Copy
    ActiveSheet.Range("L7:L16").PasteSpecial xlPasteFormulas
    Worksheets("Report").Range("K16").Copy
    ActiveSheet.Range("K16").PasteSpecial xlPasteFormulas
    Worksheets("Report").Range("J17").Copy
    ActiveSheet.Range("J17").PasteSpecial xlPasteFormulas
    Application.CutCopyMode = False
    ActiveSheet.Protect
End Sub

[joo]

ทดลองแล้วสามารถใช้งานได้ตามที่ต้องการครับ
แต่การปลดล็อคพื้นที่ยังมีปัญหาอยู่ครับคือผมเพิ่มพื้นที่การคีย์ข้อมูลเพิ่มจากเดิมจากสูตรเดิมแบบนี้
ActiveSheet.Protection.AllowEditRanges.Add _
Title:="Range1", _
Range:=Range("B7:I37,E3:G3"), _
Password:=strPassword
เพิ่มเป็น
ActiveSheet.Protection.AllowEditRanges.Add _
Title:="Range1", _
Range:=Range("B7:I37,E3:H3"), _
Password:=strPassword
ระบบไม่ยอมปลดล็อคเซลล์ H3 ให้ครับ

[snasui]

กรณีเปลี่ยนพื้นที่ในการ Protect ลองลบของเดิมทิ้งไปก่อนแล้วเพิ่มอันใหม่เข้าไปตามด้านล่างครับ

Code: Select all

   .....
    strPassword = Right(ActiveSheet.Name, 2)
    ActiveSheet.Protection.AllowEditRanges("Range1").Delete
    ActiveSheet.Protection.AllowEditRanges.Add _
    Title:="Range1", _
    Range:=Range("B7:I37,E3:G3"), _
    Password:=strPassword
    .....

[joo]

ขอบคุณครับทดลองแล้วใช้งานตามที่ต้องการครับ
ถามเพิ่มนะครับ ผมเพิ่มปุ่มค้นหาซีทโดยเขียนโค๊ดแบบนี้ครับ

Code: Select all

Sub SearchSheet()
Dim strNameSheet As String
strNameSheet = InputBox("Please enter sheet name.")
   If strNameSheet = "" Then
       Exit Sub
      End If
 Worksheets(strNameSheet).Select
 End Sub

มีปัญหาที่เมื่อใส่ชื่อซีทที่ไม่มีจะเกิด Bug ที่บรรทัดนี้ครับ Worksheets(strNameSheet).Select
จึงปรับแก้ใหม่เป็น

Code: Select all

Sub SearchSheet()
Dim i As Integer
Dim strNameSheet As String
strNameSheet = InputBox("Please enter sheet name.", "Search Name Sheet")
   If strNameSheet = "" Then
       Exit Sub
      End If
      For i = 1 To Worksheets.Count
        If UCase(Worksheets(i).Name) <> UCase(strNameSheet) Then
           MsgBox "Please try again"
           Exit Sub
        End If
Next
Worksheets(strNameSheet).Select  
End Sub

ผลปรากฎว่าไม่ว่าจะใสชื่อซีทถูกหรือผิดระบบก็จะเตือนที่บรรทัดนี้ตลอดครับ Please try again
ต้องปรับแก้ตรงส่วนไหนเพิ่มดีครับ

[snasui]

ลองปรับ Code เป็นด้านล่างครับ

Code: Select all

Sub SearchSheet()
Dim i As Integer
Dim iCount As Integer
Dim strNameSheet As String
strNameSheet = InputBox("Please enter sheet name.", "Search Name Sheet")
    If strNameSheet = "" Then
        Exit Sub
    End If
    For i = 1 To Worksheets.Count
        If UCase(Worksheets(i).Name) = UCase(strNameSheet) Then
            iCount = iCount + 1
        End If
    Next
    If iCount > 0 Then
        Worksheets(strNameSheet).Select
    Else
        MsgBox "Please try again"
    End If
End Sub

[joo]

ขอบคุณครับ สามารถใช้งานได้ดีครับ
ถามเพิ่มนะครับ ถ้าต้องการค้นหาซีทที่มีอยู่ในฐานข้อมูลทั้งหมดโดยค้นหาแบบ Combo box หรือ แบบ Value List ทำได้ไหมครับ
ถ้าได้ต้องใช้คำสั้งในการค้นหาชื่อซีททั้งหมดมาแสดงใน List Box ต้องเขียนโค๊ดแบบไหนครับ

[snasui]

เราสามารถใช้ VBA List รายชื่อชีทออกมาทั้งหมดแล้วค่อยนำไปใช้ใน ListBox หรือ Validation หรือหากไม่ต้องการใช้ VBA ก็สามารถใช้ Excel 4 Macro Function หรือ Add-ins Morefunc มาช่วยได้ครับ ดูตัวอย่างที่ http://snasui.blogspot.com/2008/11/list-sheet.html

[joo]

ผมใช้ VBA List รายชื่อชีทออกมาทั้งหมดแล้วนำไปใช้ใน Validation เพื่อค้นหารายชื่อซีททำได้แล้วครับ แต่ว่าเมื่อเลือกข้อมูลในรายการแล้วไม่สามารถให้ทำการเปิดข้อมูลของซีทนั้นๆขึ้นมาแสดงได้ต้องปรับแก้โค๊ดตรงส่วนไหนเพิ่มดีครับ โค๊ดที่ทำไว้ของซีท INDEX แบบนี้ครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strNameSheet As String
Application.EnableEvents = False
   If Target.Address = "$E$25" Then
        strNameSheet = Target.Address
       Worksheets(strNameSheet).Select
    End If
 Application.EnableEvents = True
End Sub

[snasui]

ลองเปลี่ยน Code เป็นตามด้านล่างครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$5" Then
        Worksheets(Target.Value).Select
    End If
End Sub

[joo]

ลองแล้วใช้งานได้ดีครับ แล้วถ้าต้องการให้เซลล์เมื่อได้รับโฟกัสให้แสดง Drop List อัตโนมัติ เช่นเมื่อ E25 ได้รับโฟกัสก็ให้แสดงรายการทั้งหมดลงมาให้เห็นต้องใช้คำสั่งอะไรครับ

[snasui]

การทำเช่นนั้นต้องหันไปใช้ Control Toolbox แทนการคลิกเลือกจากเซลล์ด้วย Validation ครับ จะมี Event ให้กำหนดว่าหากนำเมาส์มาชี้ก็ให้แสดง List ได้เลย

[joo]

ที่ซีท INDEX ผมสร้าง ComboBox ไว้ 1 อันแล้วฝังโค๊ดไว้ในซีทแบบนี้

Code: Select all

Private Sub ComboBox1_Click()
Dim MySheet() As String
Dim MyTotalSheets As String
Dim i As Integer
MyTotalSheets = Application.Worksheets.Count
ReDim MyName(MyTotalSheets)
    For i = 1 To MyTotalSheets
           MyName(i) = Sheets(i).Name
           ComboBox1.AddItem MyName(i)
    Next i
Worksheets(ComboBox1.Value).Select
End Sub

สร้างปุ่มคำสั่งค้นหาฝังโค๊ดไว้แบบนี้

Code: Select all

Sub GoComboBox1()
Sheets("INDEX").ComboBox1.DropDown
End Sub

ต้องการให้ซ่อน ComboBox ไว้ก่อน เมื่อคลิกปุ่มคำสั่งค้นหาก็ให้ SetFous มาที่ ComboBox เมื่อเลือกเปิดซีทดูข้อมูลได้ ก็ให้ซ่อน ComboBox ตัวนี้ไว้เหมือนเดิม ปัจจุบันตัว ComboBox มันจะแสดงในซีทที่ถูกเลือกตลอด ต้องปรับเพิ่มโค๊ดอย่างไรดีครับ

[snasui]

เมื่อคลิกคำสั่งค้นหาให้เขียน Code เช่นด้านล่างนี้แนบไว้ด้วยครับ

Code: Select all

UserForm1.ComboBox1.Visible = True

และหลังจากคลิก ComboBox1 แล้วใน Code ของ ComboBox1 ก็ Set เป็น Hide ไว้เหมือนเดิม

Code: Select all

UserForm1.ComboBox1.Visible = False

[joo]

อาจารย์ครับช่วยดูโค๊ดนี้ให้ทีครับทำไมข้อมูลถึงไม่แสดงตอนแรกที่ทำไว้ก็แสดงได้ดีอยู่

Code: Select all

Private Sub ComboBox1_Click()
Dim MyName() As String
Dim MyTotalSheets As Integer
Dim i As Integer
MyTotalSheets = Application.Worksheets.Count
ReDim MyName(MyTotalSheets)
    For i = 1 To MyTotalSheets
           MyName(i) = Sheets(i).Name
           ComboBox1.AddItem MyName(i)
    Next i
Worksheets(ComboBox1.Value).Select
End Sub

แล้วโค๊ดที่แนะนำไว้ใช้กับฟอร์มใช้ไหมครับแต่ ComboBox ที่ผมทำฝังไว้บน WorkSheet เลย ยังไม่ได้ทดสอบครับพอดีข้อมูลใน ComboBox ไม่ยอมแสดง

[snasui]

แนบไฟล์มาด้วยครับ จะได้ทดสอบจากไฟล์ที่เป็นปัญหาจริง

[joo]

ที่ซีท “INDEX” จะมีปุ่ม “ค้นหา” และ ComboBox1 เดิมทีเมื่อคลิกปุ่ม “ค้นหา” ที่ ComboBox1 จะแสดงรายชื่อซีททั้งหมดให้เห็นแต่ตอนนี้ไม่ยอมแสดงไม่รู้ว่าผิดพลาดตรงไหนครับ

[snasui]

ลองตามนี้ครับ

ที่ Module ธรรมดานำ Code นี้ไปวาง

Code: Select all

Sub FilComboBox()
Dim MyName() As String
Dim MyTotalSheets As Integer
Dim i As Integer
MyTotalSheets = Application.Worksheets.Count
ReDim MyName(MyTotalSheets)
    For i = 1 To MyTotalSheets
           MyName(i) = Sheets(i).Name
           ActiveSheet.ComboBox1.AddItem MyName(i)
    Next i
End Sub

ที่ชีท Index ปรับ Code ให้เป็นด้านล่าง

Code: Select all

Private Sub ComboBox1_Click()
    Worksheets(ComboBox1.Value).Select
End Sub

และ Assigned Macro ที่ชื่อ FilComboBox ให้กับปุ่มค้นหา ดูตัวอย่างตามไฟล์แนบครับ