Snasui Excel Forum

Posted: **Mon Oct 10, 2022 7:37 pm**

จากไฟล์ที่แนบ
ใช้ codeVB นำเข้าข้อมูลจาก ไฟล์ .csv ได้
แต่อยากป้องกันไม่ให้นำเข้าไฟล์ .csv อื่น ๆ ที่ไม่ใช่ไฟล์ที่เราต้องการ
ต้องเพิ่ม Code อย่างไรครับ

Code: Select all

Sub ImportScore()
  Dim fileToOpen As Variant
  Dim fileFilterPattern As String
  Dim wsMaster As Worksheet
  Dim wbTextImport As Workbook
  '
    If MsgBox("คุณต้องการนำเข้าผลการเรียน ใช่หรือไม่?", 36, "ยืนยันการนำเข้าผลการเรียน") = 6 Then
        Application.ScreenUpdating = False
        fileToOpen = Application.GetOpenFilename(Title:="เปิดไฟล์ .csv เพื่อนำเข้าข้อมูล", FileFilter:="Text Files (*.txt; *.csv),*.txt;*.csv")
        If fileToOpen = False Then
                MsgBox "คุณไม่ได้เลือกไฟล์ที่จะนำเข้า", vbOKOnly + vbInformation, "ยกเลิกการนำเข้าข้อมูล"
        Else
            Workbooks.Open Filename:=fileToOpen, UpdateLinks:=0, local:=True
                Set wbTextImport = ActiveWorkbook
                Set wsMaster = ThisWorkbook.ActiveSheet
                wsMaster.Unprotect Password:="1"
                wsMaster.Range("F6:S50,U6:V50,Z6:AM50,AO6:AP50").ClearContents
                       wbTextImport.Worksheets(1).Range("A1:N50").Copy
                        wsMaster.Range("F6").PasteSpecial xlPasteValues
                    wbTextImport.Worksheets(1).Range("O1:P50").Copy
                        wsMaster.Range("U6").PasteSpecial xlPasteValues
                    wbTextImport.Worksheets(1).Range("Q1:AD50").Copy
                        wsMaster.Range("Z6").PasteSpecial xlPasteValues
                    wbTextImport.Worksheets(1).Range("AE1:AF50").Copy
                        wsMaster.Range("AO6").PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                    wbTextImport.Close False
        Range("F6").Select
                wsMaster.Protect Password:="1"
    End If
        End If
Exit Sub
        Application.ScreenUpdating = True
                wsMaster.Protect Password:="1"
End Sub

หมายเหตุไฟล์ .csv ที่แนบมา ชื่อ "คะแนนคณิตศาสตร์ ห้อง1" คือตัวที่ต้องการนำเข้า
ส่วนไฟล์ชื่อ "GPAคณิตศาสตร์ ป.1" คือตัวที่ผู้ใช้งานอาจหลงนำเข้า

Posted: **Mon Oct 10, 2022 9:06 pm**

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

Code: Select all

'Other code
If MsgBox("คุณต้องการนำเข้าผลการเรียน ใช่หรือไม่?", 36, "ยืนยันการนำเข้าผลการเรียน") = 6 Then
    Application.ScreenUpdating = False
    fileToOpen = Application.GetOpenFilename(Title:="เปิดไฟล์ .csv เพื่อนำเข้าข้อมูล", FileFilter:="Text Files (*.txt; *.csv),*.txt;*.csv")
    If fileToOpen = False Then
            MsgBox "คุณไม่ได้เลือกไฟล์ที่จะนำเข้า", vbOKOnly + vbInformation, "ยกเลิกการนำเข้าข้อมูล"
    ElseIf VBA.Right(fileToOpen, InStrRev(fileToOpen, "\")) <> "คะแนนคณิตศาสตร์ ห้อง1.csv" Then
        MsgBox "Incorrect file name.", vbInformation
        Exit Sub
    Else
        Workbooks.Open Filename:=fileToOpen, UpdateLinks:=0, local:=True
'Other code

Posted: **Tue Oct 11, 2022 1:15 am**

ขอบคุณครับ
ได้ปรับตามคำแนะนำผมลองหลายรอบแล้วไม่ผ่าน
พอดีเจอโค้ดอีกตัว จึงได้ผมได้ลองปรับ

Code: Select all

Sub Import2()
  Dim fileToOpen As Variant
  Dim fileFilterPattern As String
  Dim wsMaster As Worksheet
  Dim wbTextImport As Workbook
  Dim Sum As Integer
  Dim cHead As Integer, tHead As String
  Dim rHead As Worksheet
  Application.ScreenUpdating = False
    fileFilterPattern = "Text Files (*.txt; *.csv),*.txt;*.csv"
  fileToOpen = Application.GetOpenFilename(fileFilterPattern)
  If fileToOpen = False Then
    MsgBox "คุณไม่ได้เลือกไฟล์ที่จะนำเข้า", vbOKOnly + vbInformation, "ยกเลิกการนำเข้าข้อมูล"
  Else
    Workbooks.Open Filename:=fileToOpen, UpdateLinks:=0, local:=True
    Set wbTextImport = ActiveWorkbook
    Set wsMaster = ThisWorkbook.Worksheets("sheet1")
'    wsMaster.Range("F6:S50", "U6:V50", "Z6:AM50", "AO6:AP50").ClearContents
    wsMaster.Range("F6:S50").ClearContents
    wsMaster.Range("U6:V50").ClearContents
    wsMaster.Range("Z6:AM50").ClearContents
    wsMaster.Range("AO6:AP50").ClearContents
   Set rHead = wbTextImport.Worksheets(1)
    cHead = Application.WorksheetFunction.CountA(wbTextImport.Worksheets(1).Range("1:1"))
    tHead = rHead.Range("F6") & "_" & rHead.Range("G6") & "_" & rHead.Range("H6") & "_" & rHead.Range("I6") _
    & "_" & rHead.Range("J6") & "_" & rHead.Range("K6") & "_" & rHead.Range("L6") & "_" & rHead.Range("M6") _
    & "_" & rHead.Range("N6") & "_" & rHead.Range("O6") & "_" & rHead.Range("P6") & "_" & rHead.Range("Q6") _
    & "_" & rHead.Range("R6") & "_" & rHead.Range("S6") & "_" & rHead.Range("U6") & "_" & rHead.Range("V6")


       
        If cHead <> 16 Then
        wbTextImport.Close False
        MsgBox ("ไฟล์ที่คุณเลือก มีจำนวน หรือ ตำแหน่ง คอลัมน์ผิดพลาด" & vbCrLf & "กรุณาตรวจสอบไฟล์ก่อนนำเข้าอีกครั้ง"), vbExclamation, "โปรดตรวจสอบ"
         
         Else
        wbTextImport.Worksheets(1).Range("A1").CurrentRegion.Copy
        
        wsMaster.Range("F6").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        wbTextImport.Close False
        MsgBox "นำเข้าข้อมูลนักเรียนเสร็จเรียบร้อย", vbOKOnly + vbInformation, "สถานะการนำเข้าข้อมูล"
        End If
  End If

    Range("F6").Select

    Application.ScreenUpdating = True
End Sub

แต่ยังติดอยู่ไม่สามารถ ไปต่อกรณีไฟล์นำเข้า มีคลอลัมน์ที่มีว่างกั้นอยู่ก่อนคลอลัมน์ที่ต้องการคัดลอก
จะสามารถปรับโค๊ดนี้ให้ทำงานได้อย่างไรครับ

Posted: **Tue Oct 11, 2022 1:16 am**

ไฟล์ทดลองนำเข้าอีกไฟล์

Posted: **Tue Oct 11, 2022 7:12 pm**

tigerwit wrote: Tue Oct 11, 2022 1:15 am แต่ยังติดอยู่ไม่สามารถ ไปต่อกรณีไฟล์นำเข้า มีคลอลัมน์ที่มีว่างกั้นอยู่ก่อนคลอลัมน์ที่ต้องการคัดลอก
จะสามารถปรับโค๊ดนี้ให้ทำงานได้อย่างไรครับ

กรุณาแจ้งเงื่อนไขการนำเข้ามาด้วยว่าต้องการจะตรวจสอบสิ่งใดบ้าง เมื่อตรวจสอบแล้วจะให้วางข้อมูลลักษณะใด จะได้เข้าใจตรงกันครับ

Posted: **Tue Oct 11, 2022 8:02 pm**

จาก Code นี้

Code: Select all

Sub Import2()
  Dim fileToOpen As Variant
  Dim fileFilterPattern As String
  Dim wsMaster As Worksheet
  Dim wbTextImport As Workbook
  Dim Sum As Integer
  Dim cHead As Integer, tHead As String
  Dim rHead As Worksheet
  Application.ScreenUpdating = False
    fileFilterPattern = "Text Files (*.txt; *.csv),*.txt;*.csv"
  fileToOpen = Application.GetOpenFilename(fileFilterPattern)
  If fileToOpen = False Then
    MsgBox "คุณไม่ได้เลือกไฟล์ที่จะนำเข้า", vbOKOnly + vbInformation, "ยกเลิกการนำเข้าข้อมูล"
  Else
    Workbooks.Open Filename:=fileToOpen, UpdateLinks:=0, local:=True
    Set wbTextImport = ActiveWorkbook
    Set wsMaster = ThisWorkbook.Worksheets("sheet1")
'    wsMaster.Range("F6:S50", "U6:V50", "Z6:AM50", "AO6:AP50").ClearContents
    wsMaster.Range("F6:S50").ClearContents
    wsMaster.Range("U6:V50").ClearContents
    wsMaster.Range("Z6:AM50").ClearContents
    wsMaster.Range("AO6:AP50").ClearContents
   Set rHead = wbTextImport.Worksheets(1)
    cHead = Application.WorksheetFunction.CountA(wbTextImport.Worksheets(1).Range("1:1"))
    tHead = rHead.Range("F6") & "_" & rHead.Range("G6") & "_" & rHead.Range("H6") & "_" & rHead.Range("I6") _
    & "_" & rHead.Range("J6") & "_" & rHead.Range("K6") & "_" & rHead.Range("L6") & "_" & rHead.Range("M6") _
    & "_" & rHead.Range("N6") & "_" & rHead.Range("O6") & "_" & rHead.Range("P6") & "_" & rHead.Range("Q6") _
    & "_" & rHead.Range("R6") & "_" & rHead.Range("S6") & "_" & rHead.Range("U6") & "_" & rHead.Range("V6")
      
        If cHead <> 16 Then
        wbTextImport.Close False
        MsgBox ("ไฟล์ที่คุณเลือก มีจำนวน หรือ ตำแหน่ง คอลัมน์ผิดพลาด" & vbCrLf & "กรุณาตรวจสอบไฟล์ก่อนนำเข้าอีกครั้ง"), vbExclamation, "โปรดตรวจสอบ"
         
         Else
        wbTextImport.Worksheets(1).Range("A1").CurrentRegion.Copy
        
        wsMaster.Range("F6").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        wbTextImport.Close False
        MsgBox "นำเข้าข้อมูลนักเรียนเสร็จเรียบร้อย", vbOKOnly + vbInformation, "สถานะการนำเข้าข้อมูล"
        End If
  End If

    Range("F6").Select

    Application.ScreenUpdating = True
End Sub

เมื่อใช้ทดลองนำเข้า ไฟล์ .Csv (ไฟล์แนบมาชื่อชื่อ 2.Csv)
จะสามารถนำเข้าได้เพียง 14 คลอลัมน์ จากที่ต้องการนำเข้า 16 คลอลัมน์ (คลอลัมน์ที่มีตัวเลข)
จะปรับโค๊ดอย่างไร ให้สามารถนำเข้าได้ครบ 16 คลอลัมน์
และหากนำเข้าไฟล์ที่มีคลอลัมน์ ไม่ถูกต้องก็ให้แจ้งเตือนนำเข้าไม่ได้

Posted: **Tue Oct 11, 2022 9:02 pm**

ตัวอย่าง Code สำหรับการนำเข้ามาทั้งสองพื้นที่ครับ

Code: Select all

'        If cHead <> 32 Then
'        wbTextImport.Close False
'        MsgBox ("ไฟล์ที่คุณเลือก มีจำนวน หรือ ตำแหน่ง คอลัมน์ผิดพลาด" & vbCrLf & "กรุณาตรวจสอบไฟล์ก่อนนำเข้าอีกครั้ง"), vbExclamation, "โปรดตรวจสอบ"
'
'         Else
        wbTextImport.Worksheets(1).Range("A1").CurrentRegion.Copy
        wsMaster.Range("F6").PasteSpecial xlPasteValues
        wbTextImport.Worksheets(1).Range("P1").CurrentRegion.Copy
        wsMaster.Range("U6").PasteSpecial xlPasteValues
        
        Application.CutCopyMode = False
        wbTextImport.Close False
        MsgBox "นำเข้าข้อมูลนักเรียนเสร็จเรียบร้อย", vbOKOnly + vbInformation, "สถานะการนำเข้าข้อมูล"
'        End If

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

Snasui Excel Forum

codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

Re: codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

Re: codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

Re: codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

Re: codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

Re: codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์

Re: codeVB ป้องกันการนำเข้าข้อมูลผิดไฟล์