เขียน VBA ดึงข้อมูลข้ามไฟล์

[monthikan]

สวัสดีค่ะ พอดีตอนนี้เขียน VBA ข้ามไฟล์เเล้ว Bug ค่ะ เขียนให้ดึกข้อมูลจากไฟล์ที่เป็น Database มาใส่ในไฟล์ HOME ค่ะ ตอนนี้ลองเขียนเเล้วยังรันได้ไม่ถึงขั้นตอนสูตรมัน Bug เเล้วค่ะ ตอนนี้ที่ Bug คือ Set wb = Workbooks.Open("D\Test\Database.xls") แต่ไม่มั่นใจว่าผิดตั้งเเต่เริ่มหรือเปล่าคะ ขอคำเเนะนำด้วนนะคะ (VBA ที่เขียนไปเป็นการเรียนรู้จากไฟล์ตัวอย่างๆ หลายๆ แบบ พึ่งเริ่มหัดเขียนได้ไม่นานมากหากผิดตรงไหนขอคำเเนะนำด้วยนะคะ)
Sub mylookupNewtran()
Dim lastrow As Long, wb As Workbook
Dim myrange As Range, tb As Workbook
Set tb = ThisWorkbook
With tb.Sheets(1)
lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
End With
Set wb = Workbooks.Open("D\Test\Database.xls")
Set myrange = wb.Sheets(1).Range("A:L")
On Error Resume Next
With tb.Sheets(1)
Sheets(1).Cells(7, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
Sheets(1).Cells(9, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
Sheets(1).Cells(11, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
Sheets(1).Cells(13, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
End With
wb.Close False
End Sub

[puriwutpokin]

ควรโพสโค้ด ให้เป็นโค้ดด้วยนะครับคราวหน้าครับ
เป็นนามสกุลไฟล์ Database.xlsx ให้เป็นไฟล์จริงดูครับ เพราะ เป็นคนละนามสกุล .xls กับ .xlsx

[monthikan]

อันนี้ที่เป็น Code ค่ะ

Code: Select all

Sub mylookupNewtran()
Dim lastrow As Long, wb As Workbook
Dim myrange As Range, tb As Workbook
Set tb = ThisWorkbook
With tb.Sheets(1)
lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
End With
Set wb = Workbooks.Open("D\Test\Database.xls")
Set myrange = wb.Sheets(1).Range("A:L")
On Error Resume Next
With tb.Sheets(1)
Sheets(1).Cells(7, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
Sheets(1).Cells(9, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
Sheets(1).Cells(11, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
Sheets(1).Cells(13, 5).Value = Application.WorksheetFunction.VLookup(Cells(7, 5), myrange, 5, False)
End With
wb.Close False
End Sub

[monthikan]

อันนี้เป็น Code ที่แก้ไขแล้วค่ะ ตอนนี้ Bug หลุดเเล้วค่ะ ขอบคุณค่ะ
แต่มีปัญหาต่อที่สูตรที่ต้องการไม่ขึ้นที่หน้าฟอร์มค่ะ ช่วยเเนะนำหน่อยนะคะ

Code: Select all

Sub mylookupNewtran()
    Dim lastrow As Long, wb As Workbook
    Dim myrange As Range, tb As Workbook
       Set tb = ThisWorkbook
            With tb.Sheets(1)
                lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
            End With
        Set wb = Workbooks.Open("C:\Users\Workbook\Test\Database.xlsm")
        Set myrange = wb.Sheets(1).Range("A1:L1728")
    On Error Resume Next
            With tb.Sheets(4)
                Sheets(4).Cells(7, 5).Value = Application.WorksheetFunction.VLookup(D5, myrange, 7, True)
                Sheets(4).Cells(9, 5).Value = Application.WorksheetFunction.VLookup(D5, myrange, 9, True)
                Sheets(4).Cells(11, 5).Value = Application.WorksheetFunction.VLookup(D5, myrange, 11, True)
                Sheets(4).Cells(13, 5).Value = Application.WorksheetFunction.VLookup(D5, myrange, 13, True)
            End With
        'wb.Close False
End Sub

หน้าฟอร์มที่ต้องการให่สูตรเเสดงค่ะ แนบไฟล์มาค่ะ

[puriwutpokin]

ลองปรับตามนี้ครับ

Code: Select all

Sub mylookupNewtran()
    Dim lastrow As Long, wb As Workbook
    Dim myrange As Range, tb As Workbook
       Set tb = ThisWorkbook
            With tb.Sheets(1)
                lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
            End With
        Set wb = Workbooks.Open("C:\Users\Workbook\Test\Database.xlsm")
        Set myrange = wb.Sheets(1).Range("A1:L1728")
    On Error Resume Next
            With tb.Sheets(4)
                .Cells(7, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 7, 0)
                .Cells(9, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 9, 0)
                .Cells(11, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 11, 0)
                .Cells(13, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 13, 0)
            End With
        'wb.Close False
End Sub

[monthikan]

ได้ลองทำตามแล้วค่ะ ตอนนี้การเรียกใช้ไม่ Bug เเล้วค่ะ แต่พอกด Run สูตรยังไม่คำนวณเหมือนเดิมค่ะ
ก่อนทำงานจะกดปุ่ม CLEAR TRANSACTION ก่อนค่ะเเล้วจะกดปุ่ม NEW TRANSACTION เพื่อนทำการบันทึกตัวใหม่หลังจากที่เราเปลี่ยนรหัสที่ "D5" ค่ะ อาจไม่เข้าใจเรื่องสูตรหรือใช้สูตรตรงไหนผิดเเนะนำได้นะคะ ขอบคุณค่ะ

[puriwutpokin]

ปรับตามนี้เลยครับ

Code: Select all

Sub mylookupNewTran()
    Dim lastrow As Long, wb As Workbook
    Dim mylookup As Range, tb As Workbook
        Set tb = ThisWorkbook
            With tb.Sheets(1)
                lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
            End With
        Set wb = Workbooks.Open("C:\WorkAA\Database\Database.xlsm")
        Set myrange = wb.Sheets(1).Range("A2:L1278")
    On Error Resume Next
            With tb.Sheets(1)
              .Cells(7, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 7, 0)
              .Cells(9, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 9, 0)
              .Cells(11, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 4, 0)
              .Cells(13, 4).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 10, 0)
              .Cells(7, 7).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 6, 0)
              .Cells(9, 7).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 12, 0)
              .Cells(13, 7).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 5, 0)
              .Cells(5, 7).Value = Application.WorksheetFunction.VLookup(.[D5], myrange, 11, 0)
            End With
        wb.Close False
End Sub

[monthikan]

ออกแล้วค่ะ ขอบคุณค่ะ คุณ puriwutpokin