Copy from sheet to sheet

[S_Gutt]

สอบถามนะคะ คือต้องการ Copy ข้อมูลจากหลายๆ Sheet และหลายไฟล์ให้รวมเป็น Sheet และไฟล์เดียวกันโดยรูปแบบเหมือนกันทุก Sheet แต่จำนวนบรรทัดไม่เท่ากัน มีวิธีการอย่างไรบ้างคะ ส่งไฟล์แนบแล้วนะคะ แต่ยังไม่แน่ใจว่าส่งตรงตามขั้นตอนหรือเปล่า

[snasui]

การทำเช่นนั้นต้องอาศัย VBA มาช่วยถึงจะสะดวกรวดเร็ว ผมเขียน Code มาเป็นตัวอย่างให้แล้วตามด้านล่าง ดูไฟล์แนบประกอบ

Code: Select all

Sub CollectData()
Dim wb As Workbook, wh As Worksheet
Dim r As Range, s As String
s = ThisWorkbook.Name & ActiveSheet.Name
Application.ScreenUpdating = False
For Each wb In Workbooks
    For Each wh In Worksheets
        If wb.Name & wh.Name <> s Then
            Set r = Workbooks("FileData_20110618.xls").Worksheets("AllData") _
                    .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            wh.UsedRange.Copy
            r.PasteSpecial xlPasteValues
        End If
    Next wh
Next wb
r.Offset(0, 6).EntireColumn.SpecialCells(xlCellTypeBlanks) _
        .EntireRow.Delete
Application.ScreenUpdating = True
End Sub

การใช้งานให้เปิดไฟล์ที่แนบมาให้นี้พร้อมกับไฟล์อื่น ๆ ที่ต้องการวมข้อมูล > กดแป้น Alt+F8 > เลือก CollectData > Run

[S_Gutt]

ทดลองทำแล้วมีจำนวนบรรทัดที่ได้มากกว่าข้อมูลที่มีคะ แต่เดี๋ยวจะลองทำด้วยไฟล์ใหม่อีกทีนะคะ พอดีไม่รู้ code VBA คะ เลยไม่แน่ใจว่าทำอะไรผิดขั้นตอนหรือเปล่า ขอขอบคุณนะคะ ที่ให้คำแนะนำ ถ้าอย่างไรจะแจ้งผลอีกทีคะ

[S_Gutt]

ลอง Run จากไฟล์ที่อาจารย์ทำตัวอย่างมาให้กับไฟล์ที่เครื่องแต่ทำไม่ได้ เลยทดลอง copy code vba ไปไว้ที่ไฟล์อื่นแล้วลอง Run ปรากฎว่าได้ข้อมูลที่ซ้ำกันไม่ทราบว่าสาเหตุจากอะไร ดู code vba แล้วมี wh,wb จำเป็นต้องเปลี่ยนให้ตรงกับชื่อไฟล์ที่เราต้องการ copy ข้อมูลหรือเปล่าคะ และส่งไฟล์ที่ลองทำเองมาให้อาจารย์ดูด้วยคะ เผื่อมีอะไรต้องแก้ไขเพิ่มเติม

ขอบคุณคะ

[snasui]

ผมเขียน Code ตกไปนิดนึงครับ ลองดู Code ด้านล่างครับ

Code: Select all

Sub CollectData()
Dim wb As Workbook, wh As Worksheet
Dim r As Range, s As String
s = ThisWorkbook.Name & ActiveSheet.Name
Application.ScreenUpdating = False
For Each wb In Workbooks
    For Each wh In wb.Worksheets
        If wb.Name & wh.Name <> s Then
            Set r = Workbooks("FileData_20110618.xls").Worksheets("AllData") _
                    .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            wh.UsedRange.Copy
            r.PasteSpecial xlPasteValues
        End If
    Next wh
Next wb
r.Offset(0, 6).EntireColumn.SpecialCells(xlCellTypeBlanks) _
        .EntireRow.Delete
Application.ScreenUpdating = True
End Sub

[S_Gutt]

ทำได้แล้วคะ ขอบคุณมากๆเลยคะ ถ้ากรณีนี้ต้องการไปใช้กับไฟล์อื่นที่ format อาจจะไม่เหมือนกัน อย่างเช่น มี column มากกว่านี้ ต้องแก้ไข code ที่ตรงไหนบ้างคะ ชื่อไฟล์คิดว่าน่าจะแก้ไขได้เอง แต่ตรง column หรืออันอื่นที่เป็น Key ต่างๆนี้สิอาจจะงงคะ ฝากรบกวนด้วยนะคะ

ขอบคุณอีกครั้งนะคะ

[snasui]

แก้ไข 2 ที่ครับ

คือ

Code: Select all

Set r = Workbooks("FileData_20110618.xls").Worksheets("AllData") _
                    .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

ตรง FileData_20110618.xls คือชื่อไฟล์
ตรง AllData คือชื่อ Sheet
และ

Code: Select all

r.Offset(0, 6).EntireColumn.SpecialCells(xlCellTypeBlanks) _
        .EntireRow.Delete

สำหรับ Code นี้เป็นการลบบรรทัดว่างในคอลัมน์ที่ 6 นับจากคอลัมน์ A (ดู Code แรกประกอบ เรากำหนดให้ตัวแปร r อยู่ในคอลัมน์ A)

[S_Gutt]

ขอบคุณสำหรับคำแนะนำดีๆคะ ถ้าลองทำแล้วติดปัญหาอะไรจะสอบถามใหม่นะคะ ตอนนนี้ก็เข้าไปอ่าน รวมสุดยอดเทคนิคฯค้นหาหัวข้อที่สนใจแล้วนำมาใช้งาน สำเร็จไปแล้ว 1 ชิ้นงานคะ เป็น web วิทยาทานสำหรับคนที่อยากรู้มากมายคะ อยากเป็นคนเก่งเหมือนอาจารย์ จะนำความรู้ที่ได้ไปสอนทีมงานให้มีการพัฒนายิ่งๆขี้นไปคะ ขอบคุณจากใจอีกครั้งนะคะ