ขอสอบถามเกี่ยวกับโค้ดImport ข้อมูล

[aapichaya]

ต้องการimport ข้อมูลจากโฟลเดอร์ที่เราเลือก โดยให้ข้อมูลแสดงในSheet1 ให้ข้อมูลที่importมา จัดเก็บในชีทเดิมต่อจากแถวสุดท้าย และนำข้อมูลทั้งหมดไปประมวลผลต่อไป จากที่ศึกษาเป็นการcopy worksheet ที่เพิ่มขึ้นมา before กับ after sheet ช่วยให้คำแนะนำหน่อยค่ะ

Code: Select all

Sub ImportSheet()
    Dim sImportFile As String, sFile As String
    Dim sThisBk As Workbook
    Dim vfilename As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sThisBk = ActiveWorkbook
    sImportFile = Application.GetOpenFilename( _
    FileFilter:="All Excel Files, *.xls; *.xlsx;*.xlsm;*.csv", Title:="Open Workbook")
    If sImportFile = "False" Then
        MsgBox "No File Selected!"
        Exit Sub
         
    Else
        vfilename = Split(sImportFile, "\")
        sFile = vfilename(UBound(vfilename))
        Application.Workbooks.Open Filename:=sImportFile
         
        Set wbBk = Workbooks(sFile)
        With wbBk
            If SheetExists("Raw_Data") Then
                Set wsSht = .Sheets("Raw_Data")
                wsSht.Copy before:=sThisBk.Sheets("Sheet1")
            Else
                MsgBox "There is no sheet with name :Raw_Data in:" & vbCr & .Name
            End If
            wbBk.Close SaveChanges:=False
        End With
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sWSName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sWSName)
    If Not ws Is Nothing Then SheetExists = True
End Function

[puriwutpokin]

ควรแนบไฟล์ที่จะ import เป็นตัวอย่างด้วยครับ เบื้องต้นลองศึกษาจาก นี้ครับ
http://www.snasui.com/viewtopic.php?f=3 ... ort#p72907
ติดตรงไหนมาถามกันในนี้ต่อครับ

[snasui]

ศึกษาได้จาก Video ด้านล่างนี้ ลองปรับ Code มาเองก่อน ติดตรงไหนค่อยนำมาถามกันต่อครับ

[aapichaya]

ควรแนบไฟล์ที่จะ import เป็นตัวอย่างด้วยครับ เบื้องต้นลองศึกษาจาก นี้ครับ
http://www.snasui.com/viewtopic.php?f=3 ... ort#p72907
ติดตรงไหนมาถามกันในนี้ต่อครับ

ขอบคุณมากค่ะ

[aapichaya]

ศึกษาได้จาก Video ด้านล่างนี้ ลองปรับ Code มาเองก่อน ติดตรงไหนค่อยนำมาถามกันต่อครับ

ขอบคุณมากค่ะ .
ถ้าเราต้องการเก็บไฟล์ไปเรื่อยๆ เราสามารถลบบรรทัดที่ clear content ออกได้ไหมคะ

Code: Select all

Sub collectData()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim StrPath As Variant, i As Integer, f As Byte
        StrPath = Application.GetOpenFilename(FileFilter:="All Excel Files, *.xls; *.xlsx;*.xlsm;*.csv", _
         MultiSelect:=True)
         If TypeName(StrPath) = "Boolean" Then Exit Sub
         Set db = ThisWorkbook.Sheets(1)
        
   'db.UsedRange.ClearContents
          Application.ScreenUpdating = False
            For i = 1 To UBound(StrPath)
                Set wb = Workbooks.Open(StrPath(1))
                For Each s In wb.Worksheets
                f = IIf(db.Range("a1").Value = "", 0, 1)
                If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                        End With
                        End If
                                     
                Next s
                wb.Close False
                Application.ScreenUpdating = False
                 Next i
          Application.ScreenUpdating = True
          MsgBox "Finished.", vbInformation
          
End Sub

[puriwutpokin]

ตามโค้ดถ้าไม่ต้องเคลียร์ข้อมูลเก่าก็ลบได้คำสั่งนั้นไดเลยเลยครับ

[aapichaya]

ตามโค้ดถ้าไม่ต้องเคลียร์ข้อมูลเก่าก็ลบได้คำสั่งนั้นไดเลยเลยครับ

ขอบคุณมากค่ะ

[aapichaya]

ฝากtestให้หน่อยค่ะ พอดีลองอัพโหลดทีละสองไฟล์พร้อมกันแล้ว ผลคือขึ้นไฟล์แรกสองอัน พอจะมีวิธีแก้ไขไหมคะ

ปล.ลองtestเครื่องอื่นเเล้วimport ได้ปกติเเต่เครื่องตัวเองทำไม่ได้

[aapichaya]

ผลจากการเทสในเครื่องตัวเองค่ะ

[aapichaya]

ขอโทษค่ะ ได้เเล้วค่ะพิมพ์โค้ดผิด

[aapichaya]

ถ้าเราต้องการImport ลงตารางเราต้องปรับโค้ดตรงไหนคะ ผลที่ต้องการอยู่ในชีทที่สองค่ะ ECR Approval ซึ่งการอัพโหลดข้อมูล ต้องการอัพโหลดต่อจากแถวสุดท้ายไปเรื่อยๆค่ะ

[puriwutpokin]

ไฟล์ที่ Zip มาใหญ่มากเกินกำหนดครับ เปิดแล้วไม่มีข้อมูล เอาแค่ตัวอย่าง มาก็พอครับ

[aapichaya]

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

[puriwutpokin]

Zip มาได้ครับ แต่ตัดข้อมูลให้เล็กลงครับ

[snasui]

Zip มาได้ครับ แต่ตัดข้อมูลให้เล็กลงครับ

จากที่ผมเปิดดูไฟล์ที่ Zip มาเป็นไฟล์ข้อมูลเป็น CSV ไฟล์ครับ เหตุผลที่ต้อง Zip เพราะไม่สามารถแนบ CSV ไฟล์ได้ ส่วนไฟล์โปรแกรมที่นำเข้าคือไฟล์นามสกุล .xlsm ครับ

ถ้าเราต้องการImport ลงตารางเราต้องปรับโค้ดตรงไหนคะ ผลที่ต้องการอยู่ในชีทที่สองค่ะ ECR Approval ซึ่งการอัพโหลดข้อมูล ต้องการอัพโหลดต่อจากแถวสุดท้ายไปเรื่อยๆค่ะ

ตัวอย่าง Code ตามด้านล่าง การจัดการกับ Table จะยุ่งยากกว่าการจัดการกับ Range ปกติ จะมี ListObjects เข้ามาเกี่ยวข้องด้วยครับ

Code: Select all

Sub collectData()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim StrPath As Variant, i As Integer, x As Integer
    StrPath = Application.GetOpenFilename(FileFilter:="All Excel Files," _
        & "*.xls; *.xlsx;*.xlsm;*.csv(Comma Separated Values);*.txt", _
        MultiSelect:=True)
    If TypeName(StrPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For i = 1 To UBound(StrPath)
        Set wb = Workbooks.Open(StrPath(i))
        For Each s In wb.Worksheets
           s.UsedRange.Offset(1, 0).Resize(s.UsedRange.Rows.Count - 1).Copy
           With db
               x = .ListObjects("Table4").Range.Rows.Count
               If .Range("a" & x).Value <> "" Then x = x + 1
               .Range("a" & x).PasteSpecial xlPasteValues
           End With
        Next s
        wb.Close False
        Application.ScreenUpdating = False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

[aapichaya]

ขอบคุณอาจารย์มากค่ะ