VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

suka · #1

เรียนอาจารย์และท่านผู้รู้ช่วยปรับโค้ดค่ะ

โค้ดด้านล่างนี้ใช้กับไฟล์ Book1.xlsm สร้างปุ่มเพื่อเปิดไฟล์ OP

และให้โค้ดชื่อ Database_Copy
เปิดไฟล์ PoShare.xlsx และ Copy ข้อมูลจากชีท Sheet1 ไฟล์ PoShare.xlsx มาวางที่ชีท Database ไฟล์ PO.xlsm

และโค้ดชื่อ Database_Copy2 เปิดไฟล์ NewMonth_Share.xlsx และ Copy ข้อมูลจากชีท Sheet1 ไฟล์ NewMonth_Share.xlsx มาวางที่ชีท NewMonth ไฟล์ PO.xlsm

ขอรบกวนช่วยปรับโค้ดด้านล่างค่ะ ความต้องการให้กระชับและวางข้อมูลไว ควรปรับโค้คอย่างคะ ขอบคุณค่ะ

Code: Select all

Sub MainCode_OpenPo()
    Application.Calculation = xlCalculationManual
             Application.ScreenUpdating = False
             On Error Resume Next
            Set FormPo = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\PO.xlsm")
            Call MainCodeDBCopy
    Application.Calculation = xlCalculationAutomatic
            Call CloseWS
            Application.ScreenUpdating = True
End Sub
Sub MainCodeDBCopy()
        On Error Resume Next
                Sheets("Database").ShowAllData      ' หากมี AutoFilter โค๊ดให้ปลดค่ะ 
                   Call Database_Copy
                Sheets("NewMonth").ShowAllData      ' หากมี AutoFilter โค๊ดให้ปลดค่ะ 
                   Call Database_Copy2
End Sub
Sub Database_Copy()
    Dim wbOpen As Boolean
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = "PoShare.xlsx" Then
            wbOpen = True
        End If
    Next wb
    If Not wbOpen Then
             Set wdShare = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\PoShare.xlsx", False, False)
    End If
        Windows("PoShare.xlsx").Activate
                Cells.Select
                Selection.Copy
        Windows("PO.xlsm").Activate
                Sheets("Database").Select
                Cells.Select
                ActiveSheet.Paste
                Sheets("Form").Select
End Sub
Sub Database_Copy2()
    Dim wbOpen As Boolean
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = "NewMonth_Share.xlsx" Then
            wbOpen = True
        End If
    Next wb
    If Not wbOpen Then
        Set wdShare = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\NewMonth_Share.xlsx", False, False)
    End If
      
        Windows("NewMonth_Share.xlsx").Activate
                Cells.Select
                Selection.Copy
        Windows("PO.xlsm").Activate
                Sheets("NewMonth").Select
                Cells.Select
                ActiveSheet.Paste
                Sheets("Form").Select
End Sub
Sub CloseWS()
       Windows("PoShare.xlsx").Activate
        ActiveWorkbook.Save
        ActiveWindow.Close
        Windows("NewMonth_Share.xlsx").Activate
        ActiveWorkbook.Save
        ActiveWindow.Close
         Windows("Book1.xlsm").Activate
            ActiveWorkbook.Save
            ActiveWindow.Close
End Sub

snasui · #2

Code ที่เขียนมามีปัญหาอะไรช่วยอธิบายถึงปัญหาที่เป็นด้วยครับ

การปรับ Code ให้กระชับเป็นเรื่องรอง เรื่องหลักคือ ใช้ Code นี้แล้วมีปัญหาใดครับ

suka · #3

ค่ะอาจารย์ โค้ดสามารถวางข้อมูลได้ตามต้องการค่ะ แต่ติดว่าช้าค่ะ ไม่แน่ใจว่าไฟล์ใหญ่มีผลทำให้การวางข้อมูลช้าไหมคะ

suka · #4

อาจารย์คะ ขอโพสต์เพิ่มค่ะ ใช้ Code แนบด้านบนนี้กับเครื่องที่เก็บไฟล์ใช้เวลา 00:34.57 วินาทีในการเปิดไฟล์และวางข้อมูล

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

snasui · #5

Code ที่เขียนมานั้น Copy ทั้ง Worksheet ไปวาง มีโอกาสเป็นไปได้สูงว่าจะทำงานช้ามากหากว่ามีสูตรอยู่จำนวนมากครับ

suka · #6

Code ด้านล่างนี้ได้ปรับใหม่และลองจับเวลาดูค่ะ ใช้เวลาน้อยลงเหลือ 00:25.08 ยังไม่ได้ทดสอบใช้กับเครื่งแชร์ไฟล์ค่ะ อาจารย์คะ Code นี้ควรปรับเพิ่มได้อีกไหมคะ

Code: Select all

Sub MainCode_OpenPo()
        Application.ScreenUpdating = False
        On Error Resume Next
        Set FormPo = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\PO.xlsm")
        Application.Calculation = xlCalculationManual
        Call MainCodeDBCopy
        Application.Calculation = xlCalculationAutomatic
        Call CloseWS
        Application.ScreenUpdating = True
End Sub

Sub MainCodeDBCopy()
        On Error Resume Next
        Sheets("Database").ShowAllData      ' โค๊ดสั่งให้ปลด AutoFilter
        Call Database_Copy
        Sheets("NewMonth").ShowAllData      ' โค๊ดสั่งให้ปลด AutoFilter
        Call Database_Copy2
End Sub

Sub Database_Copy()
        Dim wbOpen As Boolean
        Dim wb As Workbook
        For Each wb In Workbooks
                If wb.Name = "PoShare.xlsx" Then
                         wbOpen = True
                End If
        Next wb
        If Not wbOpen Then
                Set wdShare = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\PoShare.xlsx", False, False)
        End If
        Windows("PoShare.xlsx").Activate
        ActiveSheet.UsedRange.Copy
        Windows("PO.xlsm").Activate
        Sheets("Database").Select
        Cells.Select
        ActiveSheet.Paste
        Sheets("Form").Select
End Sub

Sub Database_Copy2()
        Dim wbOpen As Boolean
        Dim wb As Workbook
        For Each wb In Workbooks
                If wb.Name = "NewMonth_Share.xlsx" Then
                        wbOpen = True
                End If
        Next wb
        If Not wbOpen Then
                Set wdShare = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\NewMonth_Share.xlsx", False, False)
        End If
        Windows("NewMonth_Share.xlsx").Activate
        ActiveSheet.UsedRange.Copy
        Windows("PO.xlsm").Activate
        Sheets("NewMonth").Select
        Cells.Select
        ActiveSheet.Paste
        Sheets("Form").Select
End Sub

Sub CloseWS()
       Windows("PoShare.xlsx").Activate
        ActiveWorkbook.Save
        ActiveWindow.Close
        Windows("NewMonth_Share.xlsx").Activate
        ActiveWorkbook.Save
        ActiveWindow.Close
         Windows("Book1.xlsm").Activate
        ActiveWorkbook.Save
        ActiveWindow.Close
End Sub

snasui · #7

Code ยังไม่ได้ปรับในสิ่งที่ผมบอกไปครับ เท่าที่ดูเร็ว ๆ ปรับแค่การเยื้องเท่านั้น การเยื้องไม่ใช่ปัญหาของการทำงานว่าช้าหรือเร็วครับ

ส่วนใดที่เป็นการเลือกทั้งชีตให้ปรับเสียใหม่เป็นเลือกเฉพาะเท่าที่มีข้อมูลเท่านั้น เช่นเปลี่ยนจาก Cells.Copy เป็น ActiveSheet.UsedRange.Copy เช่นนี้เป็นต้น

กรณีการวาง แทนที่จะเป็น Cells.Paste ให้ปรับเป็น Range("a1").paste เป็นต้น

การไม่มีไฟล์แนบผมไม่สามารถช่วยทดสอบความเร็ว ความช้าให้ได้ครับ

suka · #8

ขอบคุณค่ะอาจารย์ หลังปรับ Code ตามที่อาจารย์แนะนำสามารถลดเวลาลงได้มาก ๆ ค่ะ

suka · #9

อาจารย์คะ ที่ไฟล์ OfenFR.xlsm ทำปุ่มเพื่อให้เปิดไฟล์ Form.xlsm Code ยังปรับใช้ไม่ได้ค่ะ
ยกเลิกการคำนวณแบบ Automatic วางที่ MainCode ได้ไหมคะ ตัวอย่าง Code ตามไฟล์แนบค่ะ
Run Code Database_Copy ติดที่ Sheets("Database").Range("a1").Paste
และ Run Code Database_Copy2 ยังไม่สามารถทำการ Copy ข้อมูลใด ๆ ได้ค่ะ

ความต้องการเมื่อกดปุ่มที่ไฟล์ OfenFR แล้วให้ Code เปิดไฟล์ Form และให้โค้ดชื่อ Database_Copy
เปิดไฟล์ Po_Share.xlsx และ Copy ข้อมูลจากชีท Sheet1 ไฟล์ Po_Share.xlsx มาวางที่ชีท Database ไฟล์ Form.xlsm

และโค้ดชื่อ Database_Copy2 เปิดไฟล์ NewMonth_Share.xlsx และ Copy ข้อมูลจากชีท Sheet1 ไฟล์ NewMonth_Share.xlsx มาวางที่ชีท NewMonth ไฟล์ Form.xlsm

Code ไฟล์แนบควรปรับอย่างไรคะ

Code: Select all

Sub MainCode_OpenForm()
        Application.ScreenUpdating = False
        On Error Resume Next
        Set FormPo = Workbooks.Open("C:\Documents and Settings\Administrator\Desktop\ถาม-ตอบ\Form.xlsm", False, False)
        Application.Calculation = xlCalculationManual
       Call Database_Copy
        Call Database_Copy2
        Application.Calculation = xlCalculationAutomatic
        Call SClosePoWS
        Application.ScreenUpdating = True
End Su

b

suka · #10

ขออนุญาตแนบไฟล์เพิ่มค่ะ

snasui · #11

ตัวอย่าง Code ตามด้านล่าง อย่าลืมเปลี่ยน Path ให้เป็นตามที่ใช้จริงครับ

Code: Select all

Sub MainCode_OpenForm()
        Dim wb As Workbook
        Set wb = ThisWorkbook
        Application.ScreenUpdating = False
        On Error Resume Next
        Set FormPo = Workbooks.Open("C:\Users\snasui\Downloads\Temp\Test\Form.xlsm", False, False)
        Application.Calculation = xlCalculationManual
        Call Database_Copy
        Call Database_Copy2
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        ThisWorkbook.Close True
End Sub

Sub Database_Copy()             ' ต้องการให้ Copy ข้อมูลจากไฟล์ PoWbShare มาไว้ที่ชีท Database ไฟล์ Form
         Dim wbOpen As Boolean
         Dim wb As Workbook
         For Each wb In Workbooks
             If wb.Name = "Po_Share.xlsx" Then
                 wbOpen = True
             End If
         Next wb
         If Not wbOpen Then
                  Set wbshare = Workbooks.Open("C:\Users\snasui\Downloads\Temp\Test\Po_Share.xlsx", False, False)
         End If
         Windows("Po_Share.xlsx").Activate
        On Error Resume Next                                   ' ดักเผื่อหากชีท Sheet1ไม่ Filter ให้ทำขั้นตอนต่อไป
        wdshare.Sheets("Sheet1").ShowAllData      ' โค๊ดสั่งให้ปลด Filter
        ActiveSheet.UsedRange.Copy
        Windows("Form.xlsm").Activate
        Sheets("Database").Range("a1").Paste
        Application.CutCopyMode = False
        wbshare.Close False
End Sub

Sub Database_Copy2()             ' ต้องการให้ Copy ข้อมูลจากไฟล์ PoWbShare มาไว้ที่ชีท NewMonthไฟล์ Form
        Dim wbOpen As Boolean
        Dim wb As Workbook
        For Each wb In Workbooks
            If wb.Name = "NewMonth_Share.xlsx" Then
                wbOpen = True
            End If
        Next wb
        If Not wbOpen Then
                 Set wdshare = Workbooks.Open("C:\Users\snasui\Downloads\Temp\Test\NewMonth_Share.xlsx", False, False)
        End If
        Windows("NewMonth_Share.xlsx").Activate
        'On Error Resume Next                                   ' ดักเผื่อหากชีท Sheet1ไม่ Filter ให้ทำขั้นตอนต่อไป
        wdshare.Sheets("Sheet1").ShowAllData      ' โค๊ดสั่งให้ปลด Filter
        ActiveSheet.UsedRange.Copy
        Windows("Form.xlsm").Activate
        Sheets("NewMonth").Range("a1").Paste
        Windows("Form.xlsm").Activate
        Sheets("NewMonth").Range ("A1")
        ActiveSheet.Paste
        Application.CutCopyMode = False
        wdshare.Close False
        Sheets("Form").Select
End Sub

suka · #12

ขอบคุณค่ะอาจารย์ Code Run ได้ตรงตามที่ต้องการแล้วค่ะ

suka · #13

เรีืยนอาจารย์ค่ะ

Code ด้านล่างนี้ ที่ไฟล์สมุดงาน1 ให้ Code Copy ข้อมูลจากไฟล์ NewMonth_Share.xlsx มาที่ไฟล์สมุดงาน1 ชีท Database แล้ต้องการให้ปิดไฟล์ NewMonth_Share.xlsx ค่ะ

ปัญหาติดที่ Run Code แล้วติดที่โค้ดตามรูปแนบคค่ะ

ความต้องการเมื่อทำการ Copy ข้อมูลมาวางแล้วปิดไฟล์ NewMonth_Share.xlsx ค่ะ

ควรปรับอย่างไรคะ

Code: Select all

Sub DTCopy()
        Dim formBook As Workbook
        Set formBook = ThisWorkbook
        Dim wbOpen As Boolean
        Dim wb As Workbook
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        For Each wb In Workbooks
            If wb.Name = "NewMonth_Share.xlsx" Then
                wbOpen = True
            End If
        Next wb
        If Not wbOpen Then
              Set wb = Workbooks.Open("C:\Documents and Settings\Administrator\Desktop\NewMonth_Share.xlsx", False, False)
        End If
        Windows("NewMonth_Share.xlsx").Activate
           If ActiveSheet.AutoFilterMode Then
                wbShare.Sheets("Sheet1").ShowAllData      ' โค๊ดสั่งให้ปลด Filter
         End If
        ActiveSheet.UsedRange.Copy
        formBook.Activate
        Sheets("Database").Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        wb.Close False
        Application.Calculation = xlCalculationAutomati
        Application.ScreenUpdating = True
End Sub

DhitiBank · #14

ผมรันโค้ดได้ตลอดครับ ไม่ติดปัญหาอะไร

-----ด้านล่างนี้ไม่เกี่ยวกับปัญหาที่เพิ่งถาม แต่ผมว่า 2 บรรทัดนี้มีอะไรขัดๆ กันครับ-----
Set [color=#FF0000]wb[/color] = Workbooks.Open...
กับ
[color=#FF0000]wbShare[/color].Sheets("Sheet1").ShowAllData

suka · #15

ขอโทษนะคะ ทำต้วอย่างผิดต้องเป็น Code นี้ค่ะ

Code: Select all

Set wbShare = Workbooks.Open

ปัญหาเมื่อรันโค้ดยังคงติดที่โค้ดนี้ค่ะ

Code: Select all

wb.Close False

หากทำคอมเม้นท์ไว้ก็สามารถรันโค้ดได้ค่ะ

snasui · #16

suka wrote:

Code: Select all

For Each wb In Workbooks
            If wb.Name = "NewMonth_Share.xlsx" Then
                wbOpen = True
            End If
        Next wb

Code ด้านบนนี้เป็นการ Loop ว่าไฟล์ "NewMonth_Share.xlsx" เปิดอยู่แล้วหรือไม่ ถ้าเปิดอยู่แล้วให้ค่าตัวแปร wbOpen เป็น True ถ้ายังไม่เปิดแสดงว่าเป็น False

suka wrote:

Code: Select all

If Not wbOpen Then
              Set wb = Workbooks.Open("C:\Documents and Settings\Administrator\Desktop\NewMonth_Share.xlsx", False, False)
        End If

Code ด้านบนนี้เป็นการตรวจสอบค่าตัวแปร weOpen ว่าเป็น False หรือไม่ หากเป็น False ให้ค่าตัวแปร wb เป็นไฟล์ "NewMonth_Share.xlsx" และหมายความว่าหากเป็น True (ไฟล์นี้เปิดอยู่แล้ว) จะไม่มีการกำหนดค่าให้กับตัวแปร wb แต่อย่างใด

และเมื่อไม่มีการกำหนดค่าให้กับตัวแปร wb การปิดไฟล์ wb ด้วย Code wb.Close False จึงเกิด Error

การแก้ไขสามารถทำได้โดยใส่ Else เข้าไปใน Statement การตรวจสอบ wbOpen เป็นด้านล่างครับ

Code: Select all

If Not wbOpen Then
   Set wb = Workbooks.Open("C:\Documents and Settings\Administrator\Desktop\NewMonth_Share.xlsx", False, False)
Else
   Set wb = Workbooks("NewMonth_Share.xlsx")        
End If

suka · #17

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

แต่พอนำโค้ดด้านล่างไปใช้กับไฟล์งานจริงกลับเกิด Error ค่ะ ตามรูปแนบค่ะ ไม่ทราบว่าทำผิดที่จุดใด ควรปรับโค้ดอย่างไรดีคะ

Code: Select all

Sub DTCopy()
        ' ต้องการให้ Copy ข้อมูลจากไฟล์ PoWbShare มาไว้ที่ชีท Database ไฟล์ Form
        Dim wbOpen As Boolean
        Dim wb As Workbook
        Dim formBook As Workbook
        Set formBook = ThisWorkbook
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        For Each wb In Workbooks
            If wb.Name = "PoWbShare.xlsx" Then
                wbOpen = True
            End If
        Next wb
        If Not wbOpen Then
            Set wb = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\PoWbShare.xlsx", False, False)
            Else
            Set wb = Workbooks("PoWbShare.xlsx")
        End If
        Windows("PoWbShare.xlsx").Activate
        If ActiveSheet.AutoFilterMode Then
                wb("Sheet1").ShowAllData      ' โค๊ดสั่งให้ปลด Filter
         End If
        ActiveSheet.UsedRange.Copy
        formBook.Activate
        Sheets("Database").Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        wb.Close False
        Application.Calculation = xlCalculationAutomati
        Application.ScreenUpdating = True
End Sub

snasui · #18

ไม่สามารถใช้ wb("Sheet1") ได้เนื่องจากไม่ถูกต้องตามหลักของการเขียน Code ควรใช้เป็นด้านล่างครับ

wb.Sheets("Sheet1")

suka · #19

อาจารย์คะได้ปรับโค้ดเป็น wb.Sheets("Sheet1") ตามนี้แล้วยังเกิด Error ตามรูปแนบค่ะ

Code: Select all

Sub DTCopy()
        ' ต้องการให้ Copy ข้อมูลจากไฟล์ PoWbShare มาไว้ที่ชีท Database ไฟล์ Form
        Dim wbOpen As Boolean
        Dim wb As Workbook
        Dim formBook As Workbook
        Set formBook = ThisWorkbook
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        For Each wb In Workbooks
            If wb.Name = "PoWbShare.xlsx" Then
                wbOpen = True
            End If
        Next wb
        If Not wbOpen Then
            Set wb = Workbooks.Open("\\Server\DATA (E)\My P S  Project.xls\PS.BookShare\AR.ระบบลูกหนี้\PoWbShare.xlsx", False, False)
            Else
            Set wb = Workbooks("PoWbShare.xlsx")
        End If
        Windows("PoWbShare.xlsx").Activate
        If ActiveSheet.AutoFilterMode Then
                wb.Sheets("Sheet1").ShowAllData      ' โค๊ดสั่งให้ปลด Filter
         End If
        ActiveSheet.UsedRange.Copy
        formBook.Activate
        Sheets("Database").Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        wb.Close False
        Application.Calculation = xlCalculationAutomati
        Application.ScreenUpdating = True
End Sub

snasui · #20

แนบไฟล์ล่าสุดพร้อมไฟล์ที่เกี่ยวข้องมาด้วย อย่าลืมลบข้อความสำคัญทิ้งไปก่อนครับ

Snasui Excel Forum

File Anatomy Add-in: แก้ปัญหาไฟล์ Excel ช้า แฮงก์ และไม่เสถียร อย่างมืออาชีพ

VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ