Code VB คัดลอกข้อมูลจากอีกไฟล์

[tigerwit]

จากไฟล์ที่แนบมามี code คัดลอกข้อมูลจากไฟล์ Name.xls มาวางที่ไฟล์ test2.xlsb ในชีท student
ถ้าหากมี user นำไฟล์ไปใช้แล้วเปลี่ยนชื่อไฟล์เป็นชื่ออื่น จะทำให้ Code นี้ไม่สามารภทพำงานได้
ขอคำแนะนำ.....ว่าเราจะเขียน Code อย่างไร สามารถทำงานได้ แม้ว่าชื่อไฟล์จะเปลี่ยนไป

Code: Select all

Sub im_stu()
Dim WB As Workbook
On Error Resume Next
Set WB = Workbooks("Name.xls")
 If MsgBox("ต้องการนำเข้าข้อมูล", 36, "ยืนยันการนำเข้า") = 6 Then
If WB Is Nothing Then
    MsgBox "ไฟล์ Name.xls ยังไม่ได้เปิด กรุณาเปิดไฟล์ก่อน", vbCritical, "กรุณาเปิดไฟล์"
    Set WB = Nothing
    On Error GoTo 0
  Else
    Windows("Name.xls").Activate
    Range("B2:G550").Select
    Selection.Copy
    Windows("test2.xlsb").Activate
    Sheets("Student").Select
    Range("B3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'        Call rank_stu
        Range("B3").Select
        MsgBox "นำเข้าเรียบร้อย "
        End If
    End If
End Sub

[snasui]

Code จะยืดหยุ่นต่อการเปลี่ยนชื่อไฟล์และตำแหน่งการวางไฟล์ด้วยการให้ผู้ใช้ไปเปิดไฟล์นั้นขึ้นมาเองครับ

หลักการคือ

1. สร้างตัวแปรสำหรับเก็บชื่อไฟล์นั้น
2. กำหนดให้ตัวแปรนั้นมีค่าเท่ากับไฟล์ที่ผู้ใช้เปิดขึ้นมา ต้องเขียนคำสั่งให้ผู้ใช้ไปเปิดไฟล์ขึ้นมาด้วย Application.GetOpenFilename... ดูตัวอย่างที่นี่ครับ https://snasui.com/viewtopic.php?t=6115#p39207
3. เปิดไฟล์ตามตัวแปรนั้น

ดูตัวอย่างเพิ่มเติมได้ที่ Open file

[tigerwit]

เข้าไปศึกษาจากลิงก์ที่แนะนำ
ได้พยายามปรับนำมาใช้แต่ก็ยังมีที่ติดขัด
จึงขอคำแนะนำต่อครับ
จาก Code

Code: Select all

Sub OpenSingleFile()
    Dim Filter As String, Title As String
    Dim FilterIndex As Integer
    Dim Filename As Variant
    On Error Resume Next
    Filter = "Excel Files (*.xls),*.xls,"
    FilterIndex = 3
    Title = Open Flie : Name.xls"
    ChDrive ("C")
    ChDir ("C:\")
    With Application
        Filename = .GetOpenFilename(Filter, FilterIndex, Title)
        ChDrive (Left(.DefaultFilePath, 1))
        ChDir (.DefaultFilePath)
    End With
    If Filename = False Then
        MsgBox "No file was selected."
        Exit Sub
    End If
    ImportThisOne CStr(Filename)
 End Sub

กรณีที่เราไม่ได้ต้องการคัดลอกข้อมูลทั้งชีท แต่ต้องการคัดลอกแค่ช่วงเชล B2:G3500 เท่านั้น
จะปรับโค๊ดอย่างไรครับ

Code: Select all

Sub ImportThisOne(sFileName As String)
    Dim oBook As Workbook
    Dim myBook As Workbook
    Set myBook = ThisWorkbook
    Workbooks.Open sFileName
    Set oBook = ActiveWorkbook
    'Now do your processing on the newly imported sheet
    'On Error Resume Next
    'Empty sheet1 of this workbook to prepare for new data:
'    myBook.Sheets("student").UsedRange.Clear
    myBook.Sheets("student").Range("B2:G3500").Clear
    'Copy new sheet into this workbook
    oBook.Worksheets(1).UsedRange.Copy Destination:=myBook.Sheets("student").Range("B2")
    'close text file, do not save changes
    oBook.Close False
    Set oBook = Nothing
 End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
    myBook.Sheets("student").Range("B2:G3500").Clear
    'Copy new sheet into this workbook
    oBook.Worksheets(1).Range("B2:G3500").Copy Destination:=myBook.Sheets("student").Range("B2")
'Other code

[tigerwit]

ขอบคุณครับผม
หากเราต้องการให้ข้อมูลที่คัดลอกมาจากต้นทาง
วางที่ชีทปลายทางโดยให้รักษารูปแบบเดิมของชีทปลายทาง
เราต้องเพิ่มเติม Code ส่วนใดบ้างครับ

Code: Select all

Sub ImportThisOne(sFileName As String)
    Dim oBook As Workbook
    Dim myBook As Workbook
    	Set myBook = ThisWorkbook
    	Workbooks.Open sFileName
    	Set oBook = ActiveWorkbook
   	myBook.Sheets("student").Range("B2:G3500").Clear
    	oBook.Worksheets(1).Range("B2:G3500").Copy Destination:=myBook.Sheets("student").Range("B3")
    'Selection.PasteSpecial Paste:=xlPasteValues
    oBook.Close False
    Set oBook = Nothing
 End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
oBook.Worksheets(1).Range("B2:G3500").Copy
myBook.Sheets("student").Range("B3").PasteSpecial xlPasteValues
'Other code

[tigerwit]

สวัสดีครับ
นั่งหน้าคอมทั้งวันปรับแก้ตามคำแนะนำแล้วก็ยังเจอปัญหาครับ
จาก Code มีปัญหาดังนี้
1. ไม่สามารถวางค่าได้ ยังคงวางแบบนำรูปแบบจากชีทต้นทางมาวาง
2. ถ้าป้องกันชีท Code จะมีปัญหาทำงานไม่ได้
3. จากที่ชีท Student ไม่ได้มีการล็อคเซล เมื่อมีการรัน Code แล้ว
เซลที่ไม่เคยติ๊กป้องกันเซล ก็จะถูกติ๊กเลือกป้องกันเซล ซึ่งจะเป็นเซลที่อยู่ถัดลงไปจากแถวสุดท้าายของข้อมูล
ผมได้ทดสอบยกเลิกการป้องกันเซลทั้งชีทแล้วรัน Code เสร็จแล้ว ลองเข้าไปตรวจสอบ ปรากฎว่ามีการติ๊ก ป้องกันเซลขึ้นมา

Code: Select all

Sub ImportThisOne(sFileName As String)
    Dim oBook As Workbook
    Dim myBook As Workbook
    Set myBook = ThisWorkbook
    Workbooks.Open sFileName
    Set oBook = ActiveWorkbook
    myBook.Sheets("student").Range("B2:G3500").Clear
    oBook.Worksheets(1).Range("B2:G3500").Copy
    myBook.Sheets("student").Range("B2").PasteSpecial xlPasteValues
    oBook.Close False
    Set oBook = Nothing
 End Sub

[snasui]

การทำงานกับชีตที่มีการป้องกันจะมีลำดับการทำงานดังนี้ครับ

1. ปลดการป้องกัน
2. คัดลอกและวางแบบค่า
3. ป้องกันกลับไปเช่นเดิม

การป้องกันและปลดการป้องกันดูที่นี่เป็นตัวอย่างครับ Protect + Unprotect

[tigerwit]

เรียนสอบถามปัญหาครับ
จากไฟล์ที่แนบมา
ช่วงเซลที่ใช้วางข้อมูล (B3:G3500) ไมได้ล็อคเซลไว้ครับ

Code: Select all

 Sub im_stu()
Dim WB As Workbook
On Error Resume Next
Set WB = Workbooks("Name.xls")
 If MsgBox("ต้องการนำเข้าข้อมูล", 36, "ยืนยันการนำเข้า") = 6 Then
If WB Is Nothing Then
    MsgBox "ไฟล์ Name.xls ยังไม่ได้เปิด กรุณาเปิดไฟล์ก่อน", vbCritical, "กรุณาเปิดไฟล์"
    Set WB = Nothing
    On Error GoTo 0
  Else
    Windows("Name.xls").Activate
    Range("B2:G1500").Select
    Selection.Copy
    Windows("pp5.xlsb").Activate
    Sheets("Student").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'        Call rank_stu
        Range("B2").Select
        MsgBox "นำเข้าเรียบร้อย "
        End If
    End If
End Sub

ถ้ารันด้วย Code นี้ ถึงแม้จะป้องกันชีทก็รันได้แบบไม่มีไม่ปัญหา

แต่ในขณะนี้ถ้ารันด้วย Code นี้

Code: Select all

Sub OpenSingleFile()
    Dim Filter As String, Title As String
    Dim FilterIndex As Integer
    Dim Filename As Variant
    On Error Resume Next
    Filter = "Excel Files (*.xls),*.xls,"
    FilterIndex = 3
    Title = "Open Flie Name.xls"
    ChDrive ("C")
    ChDir ("C:\")
    With Application
        Filename = .GetOpenFilename(Filter, FilterIndex, Title)
        ChDrive (Left(.DefaultFilePath, 1))
        ChDir (.DefaultFilePath)
    End With
    If Filename = False Then
        MsgBox "คุณไม่ได้เลือกไฟล์ ยกเลิกการนำเข้าข้อมูล"
        Exit Sub
    End If
    ImportThisOne CStr(Filename)
 End Sub
 
Sub ImportThisOne(sFileName As String)
    Dim oBook As Workbook
    Dim myBook As Workbook
    Set myBook = ThisWorkbook
    Workbooks.Open sFileName
    Set oBook = ActiveWorkbook
    myBook.Sheets("student").Range("B2:G3500").Clear
    oBook.Worksheets(1).Range("B2:G3500").Copy
    myBook.Sheets("student").Range("B2").PasteSpecial xlPasteValues
    oBook.Close False
    Set oBook = Nothing
 End Sub

จะมีปัญหา คือ
1. ถ้าไม่ป้องกันชีท สามารถคัดลอกข้อมูลมาวางได้ แต่จะวางตามรูปแบบของต้นทาง ไม่ไได้วางค่า
2.แต่ถ้าป้องกันชีท รันโค๊ดแล้วไม่มีข้อมูลมาวาง

เป็นเพราเหตุใดครับ

[snasui]

ผมตรวจสอบแล้วพบว่ายังไม่ได้ Protect ตามภาพครับ

Code ที่แนบมาก็ไม่มีส่วนที่เกี่ยวกับการยกเลิกการป้องกัน และการป้องกันกลับไปเช่นเดิม

การ Protect ถ้าทำด้วยมือวิธีการคือ คลิกขวาที่ชีตแล้วเลือก Protect Sheet หากเข้ามาตรวจดูจะต้องพบว่าชีต Student จะต้องถูกป้องกันเพื่อไม่ให้แก้ไขได้อยู่ตลอดเวลา

การทำงานด้วย Code จะปลดการป้องกันก่อน แล้วทำงานตามคำสั่งแล้วป้องกันเอาไว้เช่นเดิมดังที่กล่าวไปแล้วครับ

การกำหนดการ Locked และ UnLocked ในเซลล์ไม่ใช่การป้องกัน แต่เป็นการกำหนดเพื่อให้การป้องกันมีผลใช้ได้กับเซลล์เหล่านี้กล่าวคือ ถ้า Locked เอาไว้ เมื่อป้องกันแล้วจะแก้ไม่ได้ ถ้า Unlocked เมื่อป้องกันแล้วจะแก้ไขได้

[tigerwit]

จาก จากไฟล์ที่แนบ
ที่ชีท Student ช่วงเซล B3:G3500 จากไม่ได้ล็อคเซลไว้ เพื่อให้ User สามารถกรอกข้อมูลเพิ่มที่ละคนได้
ส่วนเซลอื่นอื่นนั้น ล็อคเซลไว้ และทำการป้องกันชีท รหัสคือ 1234
จากไฟล์นี้ผมมีข้อสงสัยระหว่า 2 Code คือ
Code แรก (im_stu) นั้นสามารถรันและวางข้อมูลที่คัดลอกมาจากไฟล์ Name.xls ได้

Code: Select all

Sub im_stu()
Dim WB As Workbook
On Error Resume Next
Set WB = Workbooks("Name.xls")
 If MsgBox("ต้องการนำเข้าข้อมูล", 36, "ยืนยันการนำเข้า") = 6 Then
If WB Is Nothing Then
    MsgBox "ไฟล์ Name.xls ยังไม่ได้เปิด กรุณาเปิดไฟล์ก่อน", vbCritical, "กรุณาเปิดไฟล์"
    Set WB = Nothing
    On Error GoTo 0
  Else
    Windows("Name.xls").Activate
    Range("B2:G1500").Select
    Selection.Copy
    Windows("pp5.xlsb").Activate
    Sheets("Student").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'        Call rank_stu
        Range("B2").Select
        MsgBox "นำเข้าเรียบร้อย "
        End If
    End If
End Sub

แต่อีก Code หนึ่ง (OpenSingleFile)

Code: Select all

Sub OpenSingleFile()
    Dim Filter As String, Title As String
    Dim FilterIndex As Integer
    Dim Filename As Variant
    On Error Resume Next
    Filter = "Excel Files (*.xls),*.xls,"
    FilterIndex = 3
    Title = "Open Flie Name.xls"
    ChDrive ("C")
    ChDir ("C:\")
    With Application
        Filename = .GetOpenFilename(Filter, FilterIndex, Title)
        ChDrive (Left(.DefaultFilePath, 1))
        ChDir (.DefaultFilePath)
    End With
    If Filename = False Then
        MsgBox "คุณไม่ได้เลือกไฟล์ ยกเลิกการนำเข้าข้อมูล"
        Exit Sub
    End If
    ImportThisOne CStr(Filename)
 End Sub
 
 [code]
Sub ImportThisOne(sFileName As String)
    Dim oBook As Workbook
    Dim myBook As Workbook
    Set myBook = ThisWorkbook
    Workbooks.Open sFileName
    Set oBook = ActiveWorkbook
    myBook.Sheets("student").Range("B2:G3500").Clear
    oBook.Worksheets(1).Range("B2:G3500").Copy
    myBook.Sheets("student").Range("B2").PasteSpecial xlPasteValues
    oBook.Close False
    Set oBook = Nothing
 End Sub

ไม่สามารถทำงานได้ ซึ่งตามจริงแล้วเซลที่ไม่ได้ถูกล็อค ถึงแม้ชีทจะมีการป้องกัน ก็ควรที่จะแก้ไข คัดลอกวางข้อมูลได้

[snasui]

Code แรกนำข้อมูลมาวางได้เพราะไม่ได้วางในตำแหน่งที่ Lock เอาไว้ครับ

Code ที่สอง Clear ข้อมูลแล้วจะทำให้คุณสมบัติกลับไปเป็นค่าตั้งต้น เซลล์ที่มีการ Unlocked จะสูญเสียคุณสมบัตินั้นไปด้วย ต้องปรับ Code เป็น myBook.Sheets("student").Range("B2:G3500").ClearContents

ที่ไม่เห็น Error เพราะเขียนบังคับไม่ให้แสดง Error เอาไว้ด้วย Code On Error Resume Next หากต้องการเห็น Error ให้ Mark บรรทัดนี้ของ Code ที่สองให้เป็น Comment ไปก่อนครับ

[tigerwit]

ขอบคุณครับผม
เคลียร์ข้อคาใจแล้วครับ

.ClearContents ล้างข้อมูล
.Clear ล้างข้อมูลและรูปแบบ