ขอ Code VBA เพื่อสร้างระบบการจัดการของเสีย

[godman]

อาจารย์ครับ ผมพบปัญหาขณะใช้งาน เนื่องจากโปรแกรมนี้ ผมต้อง share ให้ผู้ใช้งานที่แผนกอื่นๆ ใช้ด้วย แต่ปัญหาคือผมต้องมาเปิดไฟล์ดาต้าเบส ไว้รองรับตลอดเวลา เมื่อผมเปิดไว้แล้วปัญหาก็ยังไม่จบเพราะเครื่องอื่นเขากด Finish แล้วข้อมูลไม่มาเก็บไว้ที่ไฟล์ดาต้าเบส ผมควรทำอย่างไรครับ หัวหน้าผมแนะนำว่าควรทำอย่างไรก็ได้ให้ไฟล์ดาต้าเบสดังกล่าวนี้เปิดมาคู่กัน ในเครื่องใครเครื่องมัน คือเมื่อเปิดไฟล์ WasteTrack แล้วไฟล์ Databasewastetrack ก็เปิดมาคุ่กันเลย อย่างนี้มันจะแก้ปํญหานี้ได้ไหมครับ

[snasui]

การ Share File เอาไ้ว้ก็ต้องกำหนดการ Share ด้วยทั้งไฟล์ที่ Share และ Folder ที่เก็บไฟล์ที่ Share ครับ การจะให้เปิดไฟล์ในเครื่องที่ Share สามารถเพิ่ม Code ให้ผู้ใช้งา่นเปิด File ที่เก็บ Database ขึ้นมาด้วยก็ทำได้ครับ ลองปรับ Code RecordToDatabase เป็นตามด้านล่างครับ

Code: Select all

Sub RecordToDatabase()
Dim sFilename As String
Dim rs As Range
Dim rt As Range
If Worksheets("Incomplete").Range("B14") = "" Then Exit Sub
With Worksheets("Temp")
    .Range("A8:H42").Replace What:="#", Replacement:="="
    Set rs = .Range("A8", .Range("H7").Offset(.Range("I7").Value, 0))
End With
sFilename = Application.GetOpenFilename("Excel Files (*.xls),*.xls", , _
           "Select Excel Data File")
For i = 1 To Len(sFilename)
    If Mid(sFilename, i, 1) = "\" Then
        k = i + 1
    End If
Next i
If Mid(sFilename, k, 8) <> "Database" Then
    MsgBox "This file can't paste data. Please check file name."
    Exit Sub
End If
Workbooks.Open Filename:=sFilename
Set rt = Workbooks("DatabaseWasteTrack2011.xls").Worksheets("Database").Range("A65536").End(xlUp).Offset(1, 0)
rs.Copy
rt.PasteSpecial xlPasteValues
Worksheets("Temp").Range("A8:H42").Replace What:="=", Replacement:="#"
Application.CutCopyMode = False
MsgBox "OK"
End Sub

[godman]

มัน error ครับอาจารย์ มันขึ้นว่า COMPILE ERROR VARIABLE NOT DEFINE แล้วสีเหลืองก็ระบายจุดที่ ERROE ครบ คือตรง sub recordTodatabase จะเกี่ยวกับอะไรครับ ผมก็เปิดไฟล์ 2 ไฟล์แล้ว
Sub RecordToDatabase()
Dim sFilename As String
Dim rs As Range
Dim rt As Range
If Worksheets("Incomplete").Range("B14") = "" Then Exit Sub
With Worksheets("Temp")
.Range("A8:H42").Replace What:="#", Replacement:="="
Set rs = .Range("A8", .Range("H7").Offset(.Range("I7").Value, 0))
End With
sFilename = Application.GetOpenFilename("Excel Files (*.xls),*.xls", , _
"Select Excel Data File")
For i = 1 To Len(sFilename)
If Mid(sFilename, i, 1) = "\" Then
k = i + 1
End If
Next i
If Mid(sFilename, k, 8) <> "Database" Then
MsgBox "This file can't paste data. Please check file name."
Exit Sub
End If
Workbooks.Open Filename:=sFilename
Set rt = Workbooks("DatabaseWasteTrack2011.xls").Worksheets("Database").Range("A65536").End(xlUp).Offset(1, 0)
rs.Copy
rt.PasteSpecial xlPasteValues
Worksheets("Temp").Range("A8:H42").Replace What:="=", Replacement:="#"
Application.CutCopyMode = False

[snasui]

ช่วยส่งไฟล์ที่เป็นตัวอย่างของงานจริงที่ Update ล่าสุดมาอีกครั้งครับ

[godman]

ต้องขอประทานโทษครับ ณ ตอนนี้ผมใช้ไฟล์นี้ทดสอบครบ เนืี่องจากงานจริง อยู่ที่บริษัทครับ

[snasui]

ผม Copy Code มาไม่หมด ลองใหม่อีกทีตาม Code ด้านล่างครับ

Code: Select all

Sub RecordToDatabase()
Dim sFilename As String
Dim i As Integer
Dim k As Integer
Dim rs As Range
Dim rt As Range
If Worksheets("Incomplete").Range("B14") = "" Then Exit Sub
With Worksheets("Temp")
    .Range("A8:H42").Replace What:="#", Replacement:="="
    Set rs = .Range("A8", .Range("H7").Offset(.Range("I7").Value, 0))
End With
sFilename = Application.GetOpenFilename("Excel Files (*.xls),*.xls", , _
           "Select Excel Data File")
For i = 1 To Len(sFilename)
    If Mid(sFilename, i, 1) = "\" Then
        k = i + 1
    End If
Next i
If Mid(sFilename, k, 8) <> "Database" Then
    MsgBox "This file can't paste data. Please check file name."
    Exit Sub
End If
Workbooks.Open Filename:=sFilename
Set rt = Workbooks("DatabaseWasteTrack2011.xls").Worksheets("Database").Range("A65536").End(xlUp).Offset(1, 0)
rs.Copy
rt.PasteSpecial xlPasteValues
Worksheets("Temp").Range("A8:H42").Replace What:="=", Replacement:="#"
Application.CutCopyMode = False
MsgBox "OK"
End Sub

[godman]

ผมกด Finish แล้วมันก็จะ Delect Exel data file ผมก็เข้าไปเลือก Folder แล้วเปิด File ที่ชื่อ Databasewastetrack ครับ ข้อมูลถึงจะมาและทำได้ครับ

[snasui]

เนื่องจากเป็นการกำหนดให้ผู้ใช้งานเปิดไฟล์ที่เป็น Database ขึ้นมาก่อนครับ และอย่าลืม Share File นี้ไว้ด้วยครับ หากต้องวางค่าซ้ำ ๆ ในไฟล์เดียวกันจะต้องปรับ Code ใหม่เพื่อให้ตรวจสอบว่าไฟล์ยังไม่ได้เปิด หากเปิดอยู่แล้วก็ไม่ต้องแจ้งให้เปิดอีก หากต้องวางข้อมูลซ้ำ ๆ สำหรับผู้ใช้คนเดียวกัน ช่วยแจ้งมาด้วยครับ

[godman]

เนื่องจากว่า ผมได้ลอง RUN MACRO ในบริษํทดูปรากฏว่า เกิด error ว่า RUN TIME ERROE "9" Subscript out of range ครับ
ผมไม่รู็ว่ามันจะเป็นการยุ่งยากสำหรับพนักงานที่จบเพียง ม 6 หรือไม่ กับการที่พวกเขาต้องไปเลือกไฟล์ให้ถูกต้อง
ผมปิ้งไอเดียว่า ใน Excel มี SAVE WORKPLACE อยู่ด้วยใช่ไหมครับ ผมลองแล้ว ก็ใช้ได้นะครับสำหรับเครื่องผม เพราะมันก็เปิดทั้ง 2 ไฟล์พร้อมกันเหมือนกัน ขอความเห็นอาจารย์ด้วยครับว่ามันจะแก้ปํญหาได้ไหมครับ

[snasui]

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

Code: Select all

Sub RecordToDatabase()
Dim rs As Range
Dim rt As Range
If Worksheets("Incomplete").Range("B14") = "" Then Exit Sub
With Worksheets("Temp")
    .Range("A8:H42").Replace What:="#", Replacement:="="
    Set rs = .Range("A8", .Range("H7").Offset(.Range("I7").Value, 0))
End With
Set rt = Workbooks("DatabaseWasteTrack2011.xls").Worksheets("Database").Range("A65536").End(xlUp).Offset(1, 0)
rs.Copy
rt.PasteSpecial xlPasteValues
Worksheets("Temp").Range("A8:H42").Replace What:="=", Replacement:="#"
Application.CutCopyMode = False
MsgBox "OK"
End Sub