Page 1 of 2
VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Thu Sep 01, 2016 10:15 pm
by suka
เรียนอาจารย์และท่านผู้รู้ช่วยปรับโค้ดค่ะ
โค้ดด้านล่างนี้ใช้กับไฟล์ 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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Thu Sep 01, 2016 10:23 pm
by snasui

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

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Thu Sep 01, 2016 10:52 pm
by suka
ค่ะอาจารย์ โค้ดสามารถวางข้อมูลได้ตามต้องการค่ะ แต่ติดว่าช้าค่ะ ไม่แน่ใจว่าไฟล์ใหญ่มีผลทำให้การวางข้อมูลช้าไหมคะ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 02, 2016 2:08 pm
by suka
อาจารย์คะ ขอโพสต์เพิ่มค่ะ ใช้ Code แนบด้านบนนี้กับเครื่องที่เก็บไฟล์ใช้เวลา 00:34.57 วินาทีในการเปิดไฟล์และวางข้อมูล
แต่หากใช้ Code แนบด้านบนนี้กับเครื่องที่แชร์ข้อมูล จะใช้เวลาเปิดไฟล์และวางข้อมูลมากถึง 01:42.71 เลยค่ะ ช้ามาก ๆ ค่ะ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 02, 2016 6:08 pm
by snasui

Code ที่เขียนมานั้น Copy ทั้ง Worksheet ไปวาง มีโอกาสเป็นไปได้สูงว่าจะทำงานช้ามากหากว่ามีสูตรอยู่จำนวนมากครับ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 02, 2016 8:54 pm
by suka
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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 02, 2016 9:02 pm
by snasui

Code ยังไม่ได้ปรับในสิ่งที่ผมบอกไปครับ เท่าที่ดูเร็ว ๆ ปรับแค่การเยื้องเท่านั้น การเยื้องไม่ใช่ปัญหาของการทำงานว่าช้าหรือเร็วครับ
ส่วนใดที่เป็นการเลือกทั้งชีตให้ปรับเสียใหม่เป็นเลือกเฉพาะเท่าที่มีข้อมูลเท่านั้น เช่นเปลี่ยนจาก
Cells.Copy เป็น
ActiveSheet.UsedRange.Copy เช่นนี้เป็นต้น
กรณีการวาง แทนที่จะเป็น
Cells.Paste ให้ปรับเป็น
Range("a1").paste เป็นต้น
การไม่มีไฟล์แนบผมไม่สามารถช่วยทดสอบความเร็ว ความช้าให้ได้ครับ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 02, 2016 9:46 pm
by suka

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

Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Sun Sep 04, 2016 8:22 pm
by suka
อาจารย์คะ ที่ไฟล์ 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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Sun Sep 04, 2016 8:40 pm
by suka
ขออนุญาตแนบไฟล์เพิ่มค่ะ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Mon Sep 05, 2016 7:19 pm
by snasui

ตัวอย่าง 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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Tue Sep 06, 2016 10:11 am
by suka

ขอบคุณค่ะอาจารย์ Code Run ได้ตรงตามที่ต้องการแล้วค่ะ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 23, 2016 11:17 am
by suka
เรีืยนอาจารย์ค่ะ
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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 23, 2016 5:06 pm
by DhitiBank
ผมรันโค้ดได้ตลอดครับ ไม่ติดปัญหาอะไร
-----ด้านล่างนี้ไม่เกี่ยวกับปัญหาที่เพิ่งถาม แต่ผมว่า 2 บรรทัดนี้มีอะไรขัดๆ กันครับ-----
Set [color=#FF0000]wb[/color] = Workbooks.Open...
กับ
[color=#FF0000]wbShare[/color].Sheets("Sheet1").ShowAllData
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 23, 2016 6:12 pm
by suka
ขอโทษนะคะ ทำต้วอย่างผิดต้องเป็น Code นี้ค่ะ
ปัญหาเมื่อรันโค้ดยังคงติดที่โค้ดนี้ค่ะ
หากทำคอมเม้นท์ไว้ก็สามารถรันโค้ดได้ค่ะ
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Fri Sep 23, 2016 8:09 pm
by snasui
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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Sat Sep 24, 2016 1:58 pm
by suka
ขอรบกวนอีกรอบค่ะ อาจารย์แนะนำการปรับโค้ดสามารถรันได้กับไฟล์ตัวอย่างใช้ได้เลยค่ะ
แต่พอนำโค้ดด้านล่างไปใช้กับไฟล์งานจริงกลับเกิด 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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Sat Sep 24, 2016 4:32 pm
by snasui

ไม่สามารถใช้
wb("Sheet1") ได้เนื่องจากไม่ถูกต้องตามหลักของการเขียน Code ควรใช้เป็นด้านล่างครับ
wb.Sheets("Sheet1")
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Sat Sep 24, 2016 9:26 pm
by suka
อาจารย์คะได้ปรับโค้ดเป็น
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
Re: VBA เปิดไฟล์พร้อมวางข้อมูลค่ะ
Posted: Sat Sep 24, 2016 9:32 pm
by snasui

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