รบกวนดู Code ให้หน่อยครับถ้าต้องการเขียนให้สั้นกว่านี้

[moosuper013]

รบกวนทาง อาจารย์และผู้รู้ทั้งหมดครับ รบกวนช่วยดู Code ให้หน่อยครับว่าพอจะสามารถเขียนให้สั้นลงมากกว่านี้อีกไหมครับพอดีว่า พอนำไปใช้งานแล้ว Excel ค่อนข้างใช้เวลานานพอสมควร

พอดีทางผมต้องการให้ VBA ทำงานโดยการเปิดไฟล์ตามตำแหน่งที่อยู่ใน คอลัมน์ C4 และ Copyข้อมูลเฉพาะ บางคอลัมน์และมีทั้งหมด3 Sheet และนำข้อมูลที่ Copy มาวางในWorkbook ที่กำหนด

Code: Select all

Sub Imds()
Dim PathFolder As String
With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select a Folder"
    .Filters.Clear
    .AllowMultiSelect = False
    .InitialFileName = ""

   If .Show = -1 Then
       If Right(.SelectedItems(1), 1) = "\" Then
            PathFolder = .SelectedItems(1)
        Else
            PathFolder = .SelectedItems(1)
       End If
        wsI = PathFolder
    End If
    Range("C4").Select
    ActiveCell.FormulaR1C1 = PathFolder
End With
Call Dataimport
End Sub
Function Dataimport()
    Dim wbO As Workbook
    Dim wbI1 As Workbook
    Dim wbI2 As Workbook
    Dim wbI3 As Workbook
    Dim wsI1 As Worksheet
    Dim wsI2 As Worksheet
    Dim wsI3 As Worksheet
    Dim im As String
    Set wbI1 = ThisWorkbook
    Set wsI1 = wbI1.Sheets("Dataimport1")
    Set wbI2 = ThisWorkbook
    Set wsI2 = wbI2.Sheets("Dataimport2")
    Set wbI3 = ThisWorkbook
    Set wsI3 = wbI3.Sheets("Dataimport3")
    im = Sheets("Home").Range("C4")
    If im = "" Then
        MsgBox "Cancel Import Data"
        GoTo X
        End If
    Set wbO = Workbooks.Open(im)
    wbO.Sheets(1).Range("F:F").Cells.Copy wsI1.Cells.Range("A:A")
    wbO.Sheets(1).Range("B:B").Cells.Copy wsI1.Cells.Range("B:B")
    wbO.Sheets(1).Range("G:G").Cells.Copy wsI1.Cells.Range("C:C")
    wbO.Sheets(1).Range("K:K").Cells.Copy wsI1.Cells.Range("D:D")
    wbO.Sheets(2).Range("F:F").Cells.Copy wsI2.Cells.Range("A:A")
    wbO.Sheets(2).Range("B:B").Cells.Copy wsI2.Cells.Range("B:B")
    wbO.Sheets(2).Range("G:G").Cells.Copy wsI2.Cells.Range("C:C")
    wbO.Sheets(2).Range("K:K").Cells.Copy wsI2.Cells.Range("D:D")
    wbO.Sheets(3).Range("F:F").Cells.Copy wsI3.Cells.Range("A:A")
    wbO.Sheets(3).Range("B:B").Cells.Copy wsI3.Cells.Range("B:B")
    wbO.Sheets(3).Range("G:G").Cells.Copy wsI3.Cells.Range("C:C")
    wbO.Sheets(3).Range("K:K").Cells.Copy wsI3.Cells.Range("D:D")
    wbO.Close SaveChanges:=False
X:
End Function

[snasui]

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

Code: Select all

Sub Imds()
    Dim PathFolder As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select a Folder"
        .Filters.Clear
        .AllowMultiSelect = False
        .InitialFileName = ""
    
       If .Show = -1 Then
           If Right(.SelectedItems(1), 1) = "\" Then
                PathFolder = .SelectedItems(1)
            Else
                PathFolder = .SelectedItems(1)
           End If
            wsI = PathFolder
        End If
        Range("C4").Select
        ActiveCell.FormulaR1C1 = PathFolder
    End With
    Call Dataimport
End Sub

Function Dataimport()
    Dim wbO As Workbook
    Dim wbI1 As Workbook
    Dim wsI1 As Worksheet
    Dim wsI2 As Worksheet
    Dim wsI3 As Worksheet
    Dim im As String
    Set wbI1 = ThisWorkbook
    Set wsI1 = wbI1.Sheets("Dataimport1")
    Set wsI2 = wbI1.Sheets("Dataimport2")
    Set wsI3 = wbI1.Sheets("Dataimport3")
    im = Sheets("Home").Range("C4")
    If im = "" Then
        MsgBox "Cancel Import Data"
        GoTo X
    End If
    Set wbO = Workbooks.Open(im)
    wsI1.Range("A:A").Value = wbO.Sheets(1).Range("F:F").Value
    wsI1.Range("B:B").Value = wbO.Sheets(1).Range("B:B").Value
    wsI1.Range("C:C").Value = wbO.Sheets(1).Range("G:G").Value
    wsI1.Range("D:D").Value = wbO.Sheets(1).Range("K:K").Value
    wsI2.Range("A:A").Value = wbO.Sheets(2).Range("F:F").Value
    wsI2.Range("B:B").Value = wbO.Sheets(2).Range("B:B").Value
    wsI2.Range("C:C").Value = wbO.Sheets(2).Range("G:G").Value
    wsI2.Range("D:D").Value = wbO.Sheets(2).Range("K:K").Value
    wsI3.Range("A:A").Value = wbO.Sheets(3).Range("F:F").Value
    wsI3.Range("B:B").Value = wbO.Sheets(3).Range("B:B").Value
    wsI3.Range("C:C").Value = wbO.Sheets(3).Range("G:G").Value
    wsI3.Range("D:D").Value = wbO.Sheets(3).Range("K:K").Value
    wbO.Close SaveChanges:=False
X:
End Function

[moosuper013]

ขอบคุณครับอาจารย์ ทางผมได้นำไปปรับใช้ แล้วสามารถช่วยให้ Excel เร็วขึ้นพอสมควร ดีกว่าการ Copy มากๆครับ