นำข้อมูลไปเรียงต่อกันในแนวคอลัมภ์ครับท่านอาจารย์

[niwat2811]

มีข้อมูลอยู่ในเซล A21 - I25 ต้องการให้ไปบันทึกที่ Sheet 2 ต่อกันไปเป็นคอลัมภ์ ไม่ทราบต้องแก้ไข Code อย่างไรครับ

[bank9597]

ลองวางโค๊ดนี้ครับ

Code: Select all

Sub CopyValue()
On Error Resume Next
Dim r As Range, rAll As Range
Application.ScreenUpdating = False
With Sheets(1)
         Set rAll = .Range(.Range("A21:I25"), .Range("I25").End(xlUp))
         Set r = Sheets("Sheet2").Range("A11").End(xlToRight).Offset(, 1)
        rAll.Copy
        r.PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Finish"

End Sub

[niwat2811]

ได้ลองนำ Code ของท่าน bank9597 ไปลองวางดูแล้วก็ยังไม่ได้ครับ ยังไงก็ขอขอบคุณท่าน bank9597 ที่ได้ช่วยแนะนำครับ

[bank9597]

ผมลองแล้วน่ะครับ ไม่มีปัญหาใดๆ ลองดูในไฟล์แนบแล้วหรือยังครับ

จากโจทย์บอกว่า

ข้อมูลอยู่ในเซล A21 - I25 ต้องการให้ไปบันทึกที่ Sheet 2 ต่อกันไปเป็นคอลัมภ์

[niwat2811]

กรณีที่ Sheet2 เราไม่มีข้อมูลบันทึกแล้วไม่ยอมไปครับ (คือว่าได้ลองลบข้อมูลที่ Sheet2 ออกทั้งหมด)

[snasui]

ลองปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Sub CopyValue()
Dim r As Range, rAll As Range
Dim lng As Long

lng = Columns.Count
Application.ScreenUpdating = False

    With Sheets(1)
         Set rAll = .Range(.Range("A21"), .Range("I25"))
         Set r = Sheets("Sheet2").Cells(11, lng).End(xlToLeft).Offset(, 1)
        rAll.Copy
        r.PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True

MsgBox "Finish"

End Su

ลักษณะของการเก็บข้อมูลไปทางขวาแบบนี้เหมาะกับการทำรายงาน ปกติจะทำเพื่อการแสดงผลให้ง่ายต่อการดู หากทำเป็น Database จะไม่เก็บข้อมูลไปทางขวาครับ

[niwat2811]

เรียนท่านอาจารย์ครับ ผมได้ลองนำ Code ไปวางแล้ว และได้ทำการลบข้อมูลใน Sheet2 ทั้งหมด และได้กดปุ่ม To Sheet2 ปรากฎว่าข้อมูลที่บันทึกไปเริ่มต้นบันทึกที่ B11 แต่ว่าตามความต้องการ ต้องการให้เริ่มบันทึกที่ A11 ครับ รบกวนท่านอาจารย์ด้วยครับผม (ถูกต้องตามที่ท่านอาจารย์กล่าวครับคือต้องการที่จะนำไปทำรายงานครับซึ่งมีหลายร้อยหน้าครับ ขอบคุณท่านอาจารย์มากครับ)

[bank9597]

ลองเปลี่ยนที่ Offset จาก 1 เป็น 0 ครับ

Code: Select all

Sub CopyValue()
Dim r As Range, rAll As Range
Dim lng As Long

lng = Columns.Count
Application.ScreenUpdating = False

    With Sheets(1)
         Set rAll = .Range(.Range("A21"), .Range("I25"))
         Set r = Sheets("Sheet2").Cells(11, lng).End(xlToLeft).Offset(, 0)
        rAll.Copy
        r.PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True

MsgBox "Finish"

End Sub

[snasui]

ลองปรับ Code เป็นด้านล่างครับ

Code: Select all

Sub CopyValue()
Dim r As Range, rAll As Range
Dim lng As Long

lng = Columns.Count
Application.ScreenUpdating = False

    With Sheets(1)
         Set rAll = .Range(.Range("A21"), .Range("I25"))
         Set r = Sheets("Sheet2").Cells(11, lng).End(xlToLeft).Offset(, _
            IIf(Sheets("Sheet2").Range("A11") = "", 0, 1))
        rAll.Copy
        r.PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True

MsgBox "Finish"

End Sub

[niwat2811]

รายงานผลครับ จากที่ได้ทดลอง Code ของคุณ bank9597 ผลคือไปวางทับคอลัมภ์สุดท้ายของข้อมูล ส่วน Code ของท่านอาจารย์ทดลองแล้วตรงกับความต้องการเลยครับ ขอบคุณทั้งสองท่านที่ได้สละเวลาช่วยเหลือ ขอบคุณมากครับสำหรับเวปที่แสนดีแห่งนี้