การเรียกเปิดไฟล์ที่ต้องการพร้อมกับ copy ข้อมูลครับ

[wongsaton]

รบกวนทุกท่านด้วยครับ ผมต้องการ copy ข้อมูลในช่อง B18:C21 ในไฟล์ 1.xlsx. ไปวางไว้ในไฟล์ปลายทาง โดยให้โปรแกรมค้นหาชื่อไฟล์ปลายทางตามช่อง B2(ข้อมูลในช่องคือ ชื่อหัวข้อของข้อมูลครับ) เพราะมีข้อมูลจำนวนมากในไฟล์เดียวกัน ผมจึงต้องการให้โปรแกรมค้นหาชื่อไฟล์ปลายทางจากช่อง B2 เพื่อให้ชื่อข้อมูลในช่อง B2 ตรงกับชื่อของไฟล์ปลายทางที่ต้องการครับ โดยมีเงื่อนไขครับคือ ผมจะสร้างไฟล์ว่างไว้ก่อน เพื่อรองรับข้อมูลที่จะ copy ไปครับ ยกตัวอย่างครับ ชื่อหัวข้อ ข้อมูลในช่อง B2 ชื่อ 12345 ในไฟล์ 1.xlsx. ผมต้องการจะเรียกเปิดไฟล์ (ไฟล์ว่างที่ผมสร้างไว้รอรับข้อมูล) ที่เป็นชื่อ 12345 เช่นเดียวกัน โดยให้โปรแกรมค้นหาจากช่อง B2 ครับ และ copy ข้อมูลในช่อง B18:C21 ไปพร้อมกันด้วยครับ โดยตอนนี้ผมทำการ copy ข้อมูลได้แล้ว แต่ติดอยู่ตรงการค้นหาเรียกเปิดไฟล์ ให้ชื่อข้อมูลกับชื่อไฟล์ตรงกันครับ พอจะมีวิธีแก้ไขปัญหานี้ไหมครับ code การ copy ครับ

Sub Button2_คลิก()

Dim wb1 As Variant


ActiveSheet.Range("B18:C21", _
ActiveSheet.Range("B18:C21").End(xlDown).End(xlToRight)).Select

Selection.Copy
Workbooks.Open("D:\Excle VBA\12345.xlsx").Activate 'การ copy แบบเดิมของผม ซึ่งไม่ตอบโจทย์ครับเพราะแบบนี้เป็นการกำหนดไฟล์ปลายทางแน่นอนไม่สามารถเปลี่ยนได้
Range("A65000").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
MsgBox ("บันทึกข้อมูลแล้ว")


End Sub
รบกวนทุกท่านด้วยนะครับ ขอบคุณมากครับ

[bank9597]

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

Code: Select all

   Dim wbMain As Workbook
    Dim strPath As String
    Dim strFileName As String
    Set wbMain = ActiveWorkbook
    strPath = "D:\Excle VBA\"
    strFileName = wbMain.Sheets(1).Range("B2")
    
    wbMain.Sheets(1).Range("B18:C21").Copy
    Workbooks.Open (strPath & strFileName)
    
    ActiveWorkbook.Range("A1").PasteSpecial xlPasteValues

    MsgBox ("Succssful")

[wongsaton]

ขอบคุณ คุณ bank9597 มากครับ

"ActiveWorkbook.Range("A1").PasteSpecial xlPasteValues"
แต่ติดปัญหาตรงบรรทัดนี้ครับ และการ copy ข้อมูลมันไม่ได้แล้วครับ

แต่การเรียกเปิดไฟล์ปลายทางจาก row B2 ใช้ได้แล้วครับ
รบกวนแนะนำผมทีครับ

[bank9597]

เพิ่มเติมครับ ลองแทนด้วยโค๊ดด้านล่างครับ
ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues

[wongsaton]

เพิ่มเติมครับ ลองแทนด้วยโค๊ดด้านล่างครับ
ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues

ได้แล้วครับ ขอบคุณ คุณ bank9597 มากครับ
แต่ผมขอเพิ่มเติมนิดนึงครับ ผมต้องการให้โปรแกรม วนค้นหาชื่อไฟล์ปลายทางพร้อมกันหลายๆไฟล์ในครั้งเดียวได้ไหมครับ
เช่น ผมเพิ่มเติมจากเดิมที่ จะอ่านชื่อไฟล์ปลายทางจาก row B2 ช่องเดียว โดยผมต้องการให้โปรแกรมอ่านชื่อไฟล์ปลายทางจาก row I2,M2.. ไปเรื่อยๆ ตามที่กำหนด โดยมีเงื่อนไข ให้ copy ข้อมูลตาม row ที่ต้องการไปพร้อมๆกันด้วย โดยถ้าไม่มีข้อมูลก็ไม่ต้องกระทำ แบบนี้พอจะมีวิธี วนลูปได้ไหมครับ

ผมแนบไฟล์ตัวอย่างมาด้วยนะครับ
รบกวนแนะนำทีครับ ขอบคุณล่วงหน้าครับ

[bank9597]

ฟอรั่มมีกฏครับ ยังไงลองปรับมาเองก่อนครับ โค๊ดผมปรับไว้ให้แล้ว แต่อยากให้ลองคิดเองดูก่อนครับ

[wongsaton]

ฟอรั่มมีกฏครับ ยังไงลองปรับมาเองก่อนครับ โค๊ดผมปรับไว้ให้แล้ว แต่อยากให้ลองคิดเองดูก่อนครับ

ผมลองปรับดูแล้วครับ โดยใช้คำสั่ง if แต่ก็ไม่ได้ผลตามที่ต้องการครับ และยังติด Error ครับ
รบกวนทุกท่านแนะนำผมด้วยนะครับ ขอบคุณล่วงหน้าครับ

Sub Button2_¤ÅÔ¡()

Dim wbMain As Workbook
Dim strPath As String
Dim strFileName As String

Set wbMain = ActiveWorkbook
strPath = "D:\Excle VBA\"

If strFileName = wbMain.Sheets(1).Range("B2") Then
wbMain.Sheets(1).Range("B17:C21").Copy
End If

If strFileName = wbMain.Sheets(2).Range("I2") Then
wbMain.Sheets(2).Range("I17:J21").Copy
End If

If strFileName = wbMain.Sheets(3).Range("M2") Then
wbMain.Sheets(3).Range("M17:JN21").Copy
End If
ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.Sheets(2).Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.Sheets(3).Range("A1").PasteSpecial xlPasteValues

MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")

End Sub

ผมลองปรับดูดังนี้ครับ ผมแนบไฟล์มาแล้วนะครับ

[bank9597]

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

Code: Select all

    Dim wbMain As Workbook
    Dim TargetWb As Workbook
    Dim strRange As Variant
    Dim strPath As String
    Dim strFileName As String
    Dim strName As Variant
    Dim rSource As Range
    
    Application.ScreenUpdating = False
    Set wbMain = ThisWorkbook
    strPath = "D:\Excle VBA\"
    strRange = Array("B2", "I2", "M2")
    
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        Workbooks.Open(strPath & strFileName).Activate
        
        Set rSource = wbMain.Sheets(1).Range(strName).Offset(15, 0).Resize(5, 2)
        Set TargetWb = Workbooks(strFileName)
        
        rSource.Copy
        TargetWb.Sheets(1).Range("A1").PasteSpecial xlPasteValues
        TargetWb.Close savechanges:=True
        
    Next strName
    Application.ScreenUpdating = True
    MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")
    
    Set wbMain = Nothing
    Set TargetWb = Nothing
    Set rSource = Nothing

[wongsaton]

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

Code: Select all

    Dim wbMain As Workbook
    Dim TargetWb As Workbook
    Dim strRange As Variant
    Dim strPath As String
    Dim strFileName As String
    Dim strName As Variant
    Dim rSource As Range
    
    Application.ScreenUpdating = False
    Set wbMain = ThisWorkbook
    strPath = "D:\Excle VBA\"
    strRange = Array("B2", "I2", "M2")
    
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        Workbooks.Open(strPath & strFileName).Activate
        
        Set rSource = wbMain.Sheets(1).Range(strName).Offset(15, 0).Resize(5, 2)
        Set TargetWb = Workbooks(strFileName)
        
        rSource.Copy
        TargetWb.Sheets(1).Range("A1").PasteSpecial xlPasteValues
        TargetWb.Close savechanges:=True
        
    Next strName
    Application.ScreenUpdating = True
    MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")
    
    Set wbMain = Nothing
    Set TargetWb = Nothing
    Set rSource = Nothing

ขอบพระคุณ คุณ bank9597 มากครับ โค้ดทำงานได้ดีครับ ได้อย่างที่ผมต้องการเลยครับ
แต่ติดปัญหานิดหน่อยครับ ดังนี้
1. ไฟล์ปลางทาง มันปิดไปเองโดยอัตโนมัติ ผมต้องการให้มันเปิดไว้ เพื่อตรวจความถูกต้องก่อน พอจะทำได้ไหมครับ
2. ข้อมูลที่บันทึกไว้ในไฟล์ปลายทาง ผมต้องการให้ข้อมูลต่อกัน (เพราะผมต้องเก็บข้อมูลเซฟไว้ในแต่ละเดือน) แต่ปัญหาคือ พอโปรแกรมทำงาน ข้อมูลใหม่จะไปทับข้อมูลเดิม มันไม่ต่อกัน พอจะมีวิธีที่จะแก้ไขได้ไหมครับ

รบกวนด้วยนะครับ ผมจนปัญญาจริงๆครับ ผมแนบไฟล์ตัวอย่างมาด้วยครับ (ไฟล์ตัวอย่างปลายทาง เผื่อทุกท่านไม่เห็นภาพครับ)
ขอบพระคุณล่วงหน้าครับ

[snasui]

คุณ wongsaton ได้ลองปรับ Code มาเองแล้วหรือไม่ หากปรับมาเองแล้วติดขัดบรรทัดใดแจ้งมาด้วยครับ

[wongsaton]

คุณ wongsaton ได้ลองปรับ Code มาเองแล้วหรือไม่ หากปรับมาเองแล้วติดขัดบรรทัดใดแจ้งมาด้วยครับ

Sub Button2_¤ÅÔ¡()

Dim wbMain As Workbook
Dim TargetWb As Workbook
Dim strRange As Variant
Dim strPath As String
Dim strFileName As String
Dim strName As Variant
Dim rSource As Range

Application.ScreenUpdating = False
Set wbMain = ThisWorkbook
strPath = "D:\Excle VBA\"
strRange = Array("B2", "I2", "M2")

For Each strName In strRange
strFileName = wbMain.Sheets(1).Range(strName)
Workbooks.Open(strPath & strFileName).Activate

Set rSource = wbMain.Sheets(1).Range(strName).Offset(15, 0).Resize(5, 2)
Set TargetWb = Workbooks(strFileName)

rSource.Copy
TargetWb.Sheets(1).Range("A1").PasteSpecial xlPasteValues


Next strName
Application.ScreenUpdating = True
MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")

End Sub

เรียน อาจารย์ครับ ปัญหาข้อที่ 1 ผมแก้ได้แล้วครับ
แต่ปัญหาข้อที่ 2 ผมยังติดปัญหาครับ เพราะเมื่อโปรแกรมทำงาน ข้อมูลใหม่จะไปซ้ำข้อมูลเดิมครับ ทั้งที่ผมได้ทำการเซฟไว้แล้ว แต่พอรันใหม่ ข้อมูลใหม่ กลับไปทับข้อมูลเดิมครับ เพราะผมต้องการให้ข้อมูลที่จะรันใหม่ ต่อข้อมูลเดิมไปเรื่อยๆโดยไม่ทับกันครับ
พอจะมีวิธีแก้ไขไหมครับ รบกวนอาจารย์ด้วยนะครับ ขอบพระคุณ ล่วงหน้าครับ

[snasui]

กรุณาโพสต์ Code ให้แสดงเป็น Code ตามกฎข้อ 5 ด้านบนด้วยครับ

[wongsaton]

กรุณาโพสต์ Code ให้แสดงเป็น Code ตามกฎข้อ 5 ด้านบนด้วยครับ

ผมขออภัยครับอาจารย์ ผมมือใหม่ครับ ผมผิดพลาดประการใด ขออภัยด้วยนะครับ

Code: Select all

Sub Button2_¤ÅÔ¡()

    Dim wbMain As Workbook
    Dim TargetWb As Workbook
    Dim strRange As Variant
    Dim strPath As String
    Dim strFileName As String
    Dim strName As Variant
    Dim rSource As Range
    
    Application.ScreenUpdating = False
    Set wbMain = ThisWorkbook
    strPath = "D:\Excle VBA\"
    strRange = Array("B2", "I2", "M2")
    
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        Workbooks.Open(strPath & strFileName).Activate
        
        Set rSource = wbMain.Sheets(1).Range(strName).Offset(15, 0).Resize(5, 2)
        Set TargetWb = Workbooks(strFileName)
        
        rSource.Copy
        TargetWb.Sheets(1).Range("A1").PasteSpecial xlPasteValues
        
        
    Next strName
    Application.ScreenUpdating = True
    MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")
    
End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
rSource.Copy
TargetWb.Sheets(1).Range("A" & Rows.Count).End(xlUp) _
    .Offset(1, 0).PasteSpecial xlPasteValues
'Other code

[bank9597]

มารวมโค๊ดให้อีกครั้งครับ ตามที่ อ.คนควนตอบไว้

Code: Select all

    Dim wbMain As Workbook
    Dim TargetWb As Workbook
    Dim strRange As Variant
    Dim strPath As String
    Dim strFileName As String
    Dim strName As Variant
    Dim rSource As Range
    Dim tSource As Range
    
    Application.ScreenUpdating = False
    Set wbMain = ThisWorkbook
    strPath = "D:\Excle VBA\"
    strRange = Array("B2", "I2", "M2")
    
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        Workbooks.Open(strPath & strFileName).Activate
        
        Set rSource = wbMain.Sheets(1).Range(strName).Offset(15, 0).Resize(5, 2)
        Set TargetWb = Workbooks(strFileName)
        
        rSource.Copy
        Set tSource = TargetWb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        tSource.PasteSpecial xlPasteValues

    Next strName
    Application.ScreenUpdating = True
    MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")
    
    Set wbMain = Nothing
    Set TargetWb = Nothing
    Set rSource = Nothing

[wongsaton]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
rSource.Copy
TargetWb.Sheets(1).Range("A" & Rows.Count).End(xlUp) _
    .Offset(1, 0).PasteSpecial xlPasteValues
'Other code

ขอบพระคุณอาจารย์ กับคุณ bank9597 มากๆนะครับ โปรแกรมทำงานได้ดีอย่างที่ผมต้องการประมาณ 90% แล้วครับ แต่ติดปัญหาอย่างหนึ่งครับผมขอรบกวนอาจารย์กับคุณ bank9597 อีกนิดนะครับ
ผมอยากให้โปรแกรมตรวจสอบชื่อไฟล์ปลายทางจากช่องที่กำหนด (ฺฺB2,I2,M2) ถ้าไม่เจอข้อมูลให้ข้ามไปและให้หยุดการกระทำ แต่ตอนนี้พอไม่เจอข้อมูลมันจะขึ้น error เลยครับ พอจะมีวิธีแก้ไขไหมครับอาจารย์
ปล.ผมลองแก้ไขโค้ดแล้ว แต่ไม่รู้จะแก้ตรงไหนมันยิ่ง error หนักกว่าเก่าครับ ผมจนปัญญาจริงๆครับ รบกวนด้วยครับ ขอบคุณล่วงหน้าครับ

[DhitiBank]

หากลองแก้ไขเองแล้ว โปรดแนบไฟล์ที่ได้ลองแก้เองแล้วมาและควรโพสต์โค้ดที่ได้ลองทำด้วยครับถึงแม้จะผิดพลาดก็ไม่เป็นไร อาจารย์กับคุณ bank9597 จะได้ดูว่าผิดพลาดตรงไหน และจะได้แนะนำคุณ wongsaton ได้ตรงจุด เพื่อการเรียนรู้ของทั้งผู้ถามและผู้เข้ามาดูครับ

[wongsaton]

หากลองแก้ไขเองแล้ว โปรดแนบไฟล์ที่ได้ลองแก้เองแล้วมาและควรโพสต์โค้ดที่ได้ลองทำด้วยครับถึงแม้จะผิดพลาดก็ไม่เป็นไร อาจารย์กับคุณ bank9597 จะได้ดูว่าผิดพลาดตรงไหน และจะได้แนะนำคุณ wongsaton ได้ตรงจุด เพื่อการเรียนรู้ของทั้งผู้ถามและผู้เข้ามาดูครับ

Code: Select all

Sub Button2_¤ÅÔ¡()

    Dim wbMain As Workbook
    Dim TargetWb As Workbook
    Dim strRange As Variant
    Dim strPath As String
    Dim strFileName As String
    Dim strName As Variant
    Dim rSource As Range
    
    Application.ScreenUpdating = False
    Set wbMain = ThisWorkbook
    strPath = "D:\Excle VBA\"
    strRange = Array("B2", "F2", "J2")
    
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        Workbooks.Open(strPath & strFileName).Activate
        
        Set rSource = wbMain.Sheets(1).Range(strName).Offset(15, 0).Resize(5, 2)
        Set TargetWb = Workbooks(strFileName) 'เมื่อมาเปิดโปรแกรมอีกเครื่องหนึ่ง โปรแกรมเกิด error ที่บรรทัดนี้ครับ
        
        rSource.Copy
        TargetWb.Sheets(1).Range("A" & Rows.Count).End(xlUp) _
        .Offset(1, 0).PasteSpecial xlPasteValues
        
    Next strName
    Application.ScreenUpdating = True
    MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅáÅéÇ")
    
End Sub

เกิดปัญหานิดนึงครับ เมื่อผมนำโปรแกรมมาเปิดใช้งานอีกเครื่องหนึ่ง โปรแกรมเกิด error ที่บรรทัดนี้ครับ
Set TargetWb = Workbooks(strFileName) (มีลูกศรชี้และเป็นแถบสีเหลือง)
และขึ้นหน้าต่างระบุว่า run-time error '9': Subscript out of range
มันเกิดจากอะไรหรอครับ ทั้งที่ code และทุกอย่างเหมือนกันหมดเลยครับ รบกวนอาจารย์และทุกท่านแนะนำผมทีนะครับ

[bank9597]

เกิดปัญหานิดนึงครับ เมื่อผมนำโปรแกรมมาเปิดใช้งานอีกเครื่องหนึ่ง โปรแกรมเกิด error ที่บรรทัดนี้ครับ
Set TargetWb = Workbooks(strFileName) (มีลูกศรชี้และเป็นแถบสีเหลือง)
และขึ้นหน้าต่างระบุว่า run-time error '9': Subscript out of range
มันเกิดจากอะไรหรอครับ ทั้งที่ code และทุกอย่างเหมือนกันหมดเลยครับ รบกวนอาจารย์และทุกท่านแนะนำผมทีนะครับ

แก้ปัญหาล่าสุดก่อนน่ะครับ
ให้ไปที่ Folder Option > View > ติ๊กถูกหน้าช่อง Hide Extension ... > OK
แล้วรันโค๊ดดูครับ

[bank9597]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
rSource.Copy
TargetWb.Sheets(1).Range("A" & Rows.Count).End(xlUp) _
    .Offset(1, 0).PasteSpecial xlPasteValues
'Other code

ขอบพระคุณอาจารย์ กับคุณ bank9597 มากๆนะครับ โปรแกรมทำงานได้ดีอย่างที่ผมต้องการประมาณ 90% แล้วครับ แต่ติดปัญหาอย่างหนึ่งครับผมขอรบกวนอาจารย์กับคุณ bank9597 อีกนิดนะครับ
ผมอยากให้โปรแกรมตรวจสอบชื่อไฟล์ปลายทางจากช่องที่กำหนด (ฺฺB2,I2,M2) ถ้าไม่เจอข้อมูลให้ข้ามไปและให้หยุดการกระทำ แต่ตอนนี้พอไม่เจอข้อมูลมันจะขึ้น error เลยครับ พอจะมีวิธีแก้ไขไหมครับอาจารย์
ปล.ผมลองแก้ไขโค้ดแล้ว แต่ไม่รู้จะแก้ตรงไหนมันยิ่ง error หนักกว่าเก่าครับ ผมจนปัญญาจริงๆครับ รบกวนด้วยครับ ขอบคุณล่วงหน้าครับ

ให้เพิ่มโค๊ด

Code: Select all

On Error Resume Next

ไว้บนสุดครับ แล้วรันโค๊ดดู