ขอสูตร VBA copy ข้อมูลจากไฟล์หนึ่งไปอีกไฟล์ แบบมีเงื่อนไข

[nakhonchai]

ผมไม่ทราบว่าจะเขียนสูตรในการตรวจสอบเงื่อนไขนี้อย่างไรครับ
ผมเขียนแบบ Copy ปกติได้
ผมจึงไคร่ขอคำชี้แนะเรื่องสูตรการ Copy ข้อมูลด้วย VBA แบบมีเงื่อนไขดังนี้ครับ
ถ้าตรวจว่าในคอลัมน์ D ทั้งคอลัมน์ในไฟล์ Book2 ว่าตรงชื่อไหนให้ Copy ข้อมูลที่กำหนดของแถวชื่อนั้นไปใส่ที่ Sheet ที่กำหนดในไฟล์ Book1
เช่น ถ้าคอลัมน์ D ในไฟล์ Book2 เจอว่ามีแค่ AL-46 จะนำข้อมูลของแถว AL-46 ในช่องสีฟ้าไปใส่ที่ Sheet ชื่อ SL46 ในช่องที่กำหนดใน Book1
เพราะบางครั้งข้อมูลที่ได้มาจะไม่มีแถว AL-41 หรือ AL-42 บ้างในกรณี ข้อมูลของ AL-46 ก็จะขยับขึ้นมาอยู่แถวบนแทน
#ผมได้แนบไฟล์ตัวอย่างและไฟล์ VBA ที่เขียนมาไว้แล้วครับ (ปล.เห็นใส่ช่องที่ใส่โค้ด VBA เวลาโพสกัน ผมใส่ไม่เป็นครับ)
#ขอบคุณมา ณ ที่นี้มากครับ

H8 ของ Book2 ==> F98 ของ Book1
H9 ของ Book2 ==> F99 ของ Book1
H10 ของ Book2 ==> F100 ของ Book1
I8 ของ Book2 ==> H98 ของ Book1
I9 ของ Book2 ==> H99 ของ Book1
I10 ของ Book2 ==> H100 ของ Book1
J8 ของ Book2 ==> J98 ของ Book1
J9 ของ Book2 ==> J99 ของ Book1
J10 ของ Book2 ==> J100 ของ Book1
K8 ของ Book2 ==> L98 ของ Book1
K9 ของ Book2 ==> L99 ของ Book1
K10 ของ Book2 ==> L100 ของ Book1
L8 ของ Book2 ==> N98 ของ Book1
L9 ของ Book2 ==> N99 ของ Book1
L10 ของ Book2 ==> N100 ของ Book1
M8 ของ Book2 ==> P98 ของ Book1
M9 ของ Book2 ==> P99 ของ Book1
M10 ของ Book2 ==> P100 ของ Book1
#ขอขอบคุณมา ณ ที่นี่ด้วยครับ

[snasui]

กรอกข้อมูลตัวอย่างใน Book2.xlsx และข้อมูลตัวอย่างปลายทางที่ตรงกันกับข้อมูลต้นทางแล้วแนบไฟล์ตัวอย่างทั้งหมดมาใหม่ครับ

สำหรับการวาง Code ให้แสดงเป็น Code อ่านกฎการใช้บอร์ดข้อ 5 ด้านบนครับ

[nakhonchai]

สวัสดีครับอาจารย์
ก่อนอื่นขอขอบคุณมากครับสำหรับปัญหาของผม
ผมได้กรอกข้อมูลต้นทางที่ Book2.xlsx และข้อมูลปลายทางที่ Book1.xlsx แล้วครับ

Code: Select all

Sub Copy()
    Set wbSource = Workbooks("Book2.xlsx")
    Set shSource = wbSource.Sheets("Data")
    Set wbTaget = Workbooks("Book1.xlsx")
    Set shTaget1 = wbTaget.Sheets(" SL41")
    Set shTaget2 = wbTaget.Sheets(" SL42")
    Set shTaget3 = wbTaget.Sheets(" SL46")
    Set shTaget4 = wbTaget.Sheets(" SL37")
    '-----------------------------------------------------------------------------------
        shTaget1.Range("F98:F100").Value = shSource.Range("H2:H4").Value
        shTaget1.Range("H98:H100").Value = shSource.Range("I2:I4").Value
        shTaget1.Range("J98:J100").Value = shSource.Range("J2:J4").Value
        shTaget1.Range("L98:L100").Value = shSource.Range("K2:K4").Value
        shTaget1.Range("N98:N100").Value = shSource.Range("L2:L4").Value
        shTaget1.Range("P98:P100").Value = shSource.Range("M2:M4").Value
        
        shTaget2.Range("F98:F100").Value = shSource.Range("H5:H7").Value
        shTaget2.Range("H98:H100").Value = shSource.Range("I5:I7").Value
        shTaget2.Range("J98:J100").Value = shSource.Range("J5:J7").Value
        shTaget2.Range("L98:L100").Value = shSource.Range("K5:K7").Value
        shTaget2.Range("N98:N100").Value = shSource.Range("L5:L7").Value
        shTaget2.Range("P98:P100").Value = shSource.Range("M5:M7").Value
        
        shTaget3.Range("F98:F100").Value = shSource.Range("H8:H10").Value
        shTaget3.Range("H98:H100").Value = shSource.Range("I8:I10").Value
        shTaget3.Range("J98:J100").Value = shSource.Range("J8:J10").Value
        shTaget3.Range("L98:L100").Value = shSource.Range("K8:K10").Value
        shTaget3.Range("N98:N100").Value = shSource.Range("L8:L10").Value
        shTaget3.Range("P98:P100").Value = shSource.Range("M8:M10").Value
        
        shTaget4.Range("F98:F100").Value = shSource.Range("H11:H13").Value
        shTaget4.Range("H98:H100").Value = shSource.Range("I11:I13").Value
        shTaget4.Range("J98:J100").Value = shSource.Range("J11:J13").Value
        shTaget4.Range("L98:L100").Value = shSource.Range("K11:K13").Value
        shTaget4.Range("N98:N100").Value = shSource.Range("L11:L13").Value
        shTaget4.Range("P98:P100").Value = shSource.Range("M11:M13").Value
End Sub

[nakhonchai]

ขอโทษครับอาจารย์
ผมลืมแนบไฟล์ครับ

[snasui]

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

Code: Select all

Sub Test0()
    Dim rall As Range, shStr As String
    Dim rs As Range, rt As Range
    Dim i As Integer, j As Integer
    With Workbooks("Book2.xlsx").Worksheets("Data")
        Set rall = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
        For i = 1 To rall.Count Step 3
            shStr = Replace(rall(i).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f98")
            For j = 4 To 8
                rt.Resize(3).Value = _
                    rall(i).Offset(0, j).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next j
        Next i
    End With
End Sub

[nakhonchai]

ขอบคุณอาจารย์มากๆเลยครับตรงตามต้องการเลยครับ
รบกวนอาจารย์ช่วยอธิบายสูตรคำสั่งให้หน่อยได้ไหมครับ
หรือแนะนำให้ผมหน่อยว่าจะศึกษาคำสั่งสูตรได้จากไหนบ้างครับ
ผมไม่มีความรู้เรื่องคำสั่งเลย สูตรที่ผมเขียนก่อนหน้า
ผมหาศึกษาทางเนตแล้วมาแปลงเอาน่ะครับ

[nakhonchai]

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

[snasui]

ขอบคุณอาจารย์มากๆเลยครับตรงตามต้องการเลยครับ
รบกวนอาจารย์ช่วยอธิบายสูตรคำสั่งให้หน่อยได้ไหมครับ
หรือแนะนำให้ผมหน่อยว่าจะศึกษาคำสั่งสูตรได้จากไหนบ้างครับ
ผมไม่มีความรู้เรื่องคำสั่งเลย สูตรที่ผมเขียนก่อนหน้า
ผมหาศึกษาทางเนตแล้วมาแปลงเอาน่ะครับ

กรุณาถามในส่วนที่ไม่เข้าใจ ผมขออภัยที่ไม่แปล Code เป็นรายบรรทัดครับ

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

ได้ปรับ Code มาแล้วหรือไม่ครับ หากปรับมาแล้วกรุณาโพสต์ Code นั้นมาด้วยพร้อมทั้งอธิบายว่าต้องการจะเขียนให้ทำงานในลักษณะใด จะได้ทราบปัญหาโดยสังเขปครับ

[nakhonchai]

ผมลองเพิ่มเติมสูตรของอาจารย์ให้สามารถ copy ในคอลัมน์อื่นๆ
รบกวนอาจารย์ช่วยตรวจสอบให้ทีครับ

Code: Select all

Sub Test0()
    Dim rall As Range, shStr As String
    Dim rs As Range, rt As Range
    Dim i As Integer, j As Integer
    Dim k As Integer, l As Integer
    Dim m As Integer, n As Integer
    Dim o As Integer, p As Integer
    Dim q As Integer, r As Integer
    Dim v As Integer, w As Integer
    
    With Workbooks("Book2.xlsx").Worksheets("Data")
        Set rall = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
        For i = 1 To rall.Count Step 3
            shStr = Replace(rall(i).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f101")
            For j = 4 To 9
                rt.Resize(3).Value = _
                    rall(i).Offset(0, j).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next j
        Next i
         
        For k = 1 To rall.Count Step 3
            shStr = Replace(rall(k).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f104")
            For l = 12 To 17
                rt.Resize(3).Value = _
                    rall(k).Offset(0, l).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next l
        Next k
        
        For m = 1 To rall.Count Step 3
            shStr = Replace(rall(m).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f98")
            For n = 24 To 29
                rt.Resize(3).Value = _
                    rall(m).Offset(0, n).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next n
        Next m
        
        For o = 1 To rall.Count Step 3
            shStr = Replace(rall(o).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f119")
            For p = 38 To 40
                rt.Resize(3).Value = _
                    rall(o).Offset(0, p).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next p
        Next o
        
        For q = 1 To rall.Count Step 3
            shStr = Replace(rall(q).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f116")
            For r = 41 To 46
                rt.Resize(3).Value = _
                    rall(q).Offset(0, r).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next r
        Next q
        
            For v = 1 To rall.Count Step 3
            shStr = Replace(rall(v).Value, "A", " S")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book1.xlsx").Worksheets(shStr).Range("f113")
            For w = 47 To 52
                rt.Resize(3).Value = _
                    rall(v).Offset(0, w).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next w
        Next v
        
    End With

End Sub

[snasui]

Code ที่เขียนมานั้นผิดพลาดตรงไหน อย่างไร ช่วยอธิบายประกอบด้วยครับ

[nakhonchai]

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

[snasui]

กรณี Code ทำงานได้ไม่จำเป็นต้องปรับ ควรใช้ตามที่เราเข้าใจไปก่อน ค่อย ๆ ศึกษาครับ

เอาไว้มีปัญหาค่อยถามกันมาใหม่ครับ

[nakhonchai]

สวัสดีครับอาจารย์
ผมขอรบกวนขอคำชี้แนะเนื่องสูตร VBA ครับ
จากคราวก่อนที่อาจารย์ได้แนะนำสูตรการ Copy ไว้ให้ ผมลองมาแก้ไขเพิ่มเติม แต่ไม่สามารถทำงานได้
เนื่องจากมีเงื่อนไขเพิ่มเข้ามาครับ เงื่อนไขที่ว่า คือ ต้องการ Copy ข้อมูลจาก 2 ไฟล์มาไว้ที่ไฟล์เดียวกัน
ถ้าคอลัมน์ D ในไฟล์ Lower และ Upper เจอว่ามี M-5A จะนำข้อมูลที่ต้องการของแถว M-5A ไปใส่ที่ Sheet ชื่อ M-5A ในช่องที่กำหนดในไฟล์ Book
****ถ้าชื่อ Sheet เป็นลักษณะ M-5_9A แบบนี้สูตร VBA ทำได้มั้ยครับ
ผมได้แนบไฟล์ตัวอย่างการลงข้อมูลมาให้แล้วครับ และไฟล์ที่ลองแก้ไขแต่ไม่เวิร์ค 5555
#ขอบคุณมา ณ ที่นี้มากครับ

Code: Select all

Sub Test0()
    Dim rall As Range, shStr As String
    Dim rs As Range, rt As Range
    Dim i As Integer, j As Integer
    Dim k As Integer, l As Integer
    Dim m As Integer, n As Integer
    Dim o As Integer, p As Integer
    Dim q As Integer, r As Integer
    Dim v As Integer, w As Integer
        
    With Workbooks("ME15812 LOWER.xlsx").Worksheets("LOWER")
        Set rall = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
        For i = 1 To rall.Count Step 8
            shStr = Replace(rall(i).Value, "M", " M")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E98")
            For j = 4 To 4
                            rt.Resize(3).Value = _
                    rall(i).Offset(0, j).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next j
        Next i
         
        For k = 1 To rall.Count Step 8
            shStr = Replace(rall(k).Value, "M", " M")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("H108")
            For l = 5 To 7
                rt.Resize(3).Value = _
                    rall(k).Offset(0, l).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next l
        Next k
        
        For m = 1 To rall.Count Step 8
            shStr = Replace(rall(m).Value, "M", " M")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E117")
            For n = 10 To 15
                rt.Resize(3).Value = _
                    rall(m).Offset(0, n).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next n
        Next m
        
        For o = 1 To rall.Count Step 8
            shStr = Replace(rall(o).Value, "M", " M")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E126")
            For p = 17 To 22
                rt.Resize(3).Value = _
                    rall(o).Offset(0, p).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next p
        Next o
        
        
        With Workbooks("ME15812 UPPER.xlsx").Worksheets("UPPER")
        For q = 1 To rall.Count Step 8
            shStr = Replace(rall(q).Value, "M", " M")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E108")
            For r = 4 To 6
                rt.Resize(3).Value = _
                    rall(q).Offset(0, r).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next r
        Next q
        
            For v = 1 To rall.Count Step 8
            shStr = Replace(rall(v).Value, "M", " M")
            shStr = Replace(shStr, "-", "")
            Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E162")
            For w = 7 To 9
                rt.Resize(3).Value = _
                    rall(v).Offset(0, w).Resize(3).Value
                Set rt = rt.Offset(0, 1)
            Next w
        Next v
               
        End With

End Sub

[nakhonchai]

ไฟล์ VBA ที่ลองแก้ไขครับ

[snasui]

ตั้งชื่อไฟล์แนบให้สอดคล้องกับที่เขียนไว้ใน Code แล้วแนบมาใหม่อีกครั้งครับ Code ที่มีปัญหาเริ่มติดขัดที่บรรทัดใดกรุณาแจ้งมาด้วยจะได้เข้าถึงปัญหาโดยไวครับ

[nakhonchai]

ขอโทษอาจารย์ด้วยครับ ผมลืมเปลี่ยนชื่อไฟล์ให้สอดคล้องกัน
เมื่อผมกดให้ทำงาน ขึ้นหน้า Run-time Error '9': แล้วผมกดปุ่ม Debug จะฟ้องที่บรรทัดนี้ครับ
ขอบคุณอาจารย์มากๆครับ

Code: Select all

Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E98")

[snasui]

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

Code: Select all

'Other code
With Workbooks("ME15812 LOWER.xlsx").Worksheets("LOWER")
    Set rall = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
    For i = 1 To rall.Count Step 8
'            shStr = Replace(rall(i).Value, "M", " M")
'            shStr = Replace(shStr, "-", "")
        shStr = rall(i).Value
        Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E98")
        For j = 4 To 4
                rt.Resize(3).Value = _
                rall(i).Offset(0, j).Resize(3).Value
            Set rt = rt.Offset(0, 1)
        Next j
    Next i     
'Other code   

End With

With Workbooks("ME15812 UPPER.xlsx").Worksheets("UPPER")
'Other code

หมายเหตุ

1. ไฟล์ Book แก้ชื่อชีตใหม่ทุกชีตห้ามมีวรรค
2. ก่อนจะขึ้นไฟล์ Upper ใน Code ต้องปิดด้วย End With เสียก่อน

[nakhonchai]

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

บรรทัดที่แสดง Error

Code: Select all

Set rt = Workbooks("Book.xlsx").Worksheets(shStr).Range("E98")

[snasui]

ผมยังพบค่าวรรคหลังชือชีตครับ

เมื่อลบ - ออกจากชื่อชีตของไฟล์ Book.xlsx ค่าในคอลัมน์ D ของไฟล์ที่ลงท้ายด้วย Upper, Lower จะต้องลบ - ออกด้วยเช่นกัน ถ้ามี - ก็ต้องมีให้เหมือนกันครับ

[nakhonchai]

เรียนอาจารย์
เรื่องชื่อชีทผมผิดพลาดต้องขออภัยด้วยครับ ผมดูไม่รอบคอบเองครับ

หลังแก้ไขแล้ว ผมอลงใส่สูตรให้ดึงค่ามาแค่ชีทเดียว
สามารถ copy ข้อมูลมาได้แค่ 3 บรรทัด และมีข้อมูลอยู่ในชีทอื่นด้วยครับ
รบกวนอาจารย์ช่วยชี้แนะด้วยครับ
ข้อมูลเป็นดังเอกสารแนบครับ
ขอบคุณอารย์มากครับ