Excel Forum

snasui wrote: ช่วยทำตัวอย่างผลลัพธ์ที่ต้องการมาด้วยเพื่อจะได้เข้าใจตรงกันครับ

snasui wrote: ทำมาใน Excel ครับ ชี้ให้เห็นว่าเดิมข้อมูลอยู่ในชีทไหน เซลล์ไหน ต้องการคำตอบในชีทไหน เซลล์ไหน มีค่าเท่าใดบ้าง ฯลฯ

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

Code: Select all

Sub test()
    Dim r1 As Range, r2 As Range
    Dim rTarget As Range
    With Sheets("¡ÐàªéÒ")
        Set r1 = .Range("a30:g30")
        Set r2 = .Range("b9:j16")
    End With
    With Sheets("DataM")
        Set rTarget = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
        r1.Copy
        rTarget.Resize(r2.Rows.Count).PasteSpecial xlPasteValues
        r2.Copy
        rTarget.Offset(0, r1.Columns.Count).PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
End Sub

สำหรับการสอนมีทีมงานที่สนิทกันสอนอยู่ครับ ลองติดต่อไปตาม Link นี้ครับ viewtopic.php?f=12&t=6255

Tahiti80s wrote:

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

Code: Select all

Sub test()
    Dim r1 As Range, r2 As Range
    Dim rTarget As Range
    With Sheets("¡ÐàªéÒ")
        Set r1 = .Range("a30:g30")
        Set r2 = .Range("b9:j16")
    End With
    With Sheets("DataM")
        Set rTarget = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
        r1.Copy
        rTarget.Resize(r2.Rows.Count).PasteSpecial xlPasteValues
        r2.Copy
        rTarget.Offset(0, r1.Columns.Count).PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
End Sub

สำหรับการสอนมีทีมงานที่สนิทกันสอนอยู่ครับ ลองติดต่อไปตาม Link นี้ครับ viewtopic.php?f=12&t=6255

ขอบคุณมากๆครับอาจารย์ ^^

snasui wrote: สามารถใช้ Code นี้แทน Code เดิมครับ

สำหรับ VBA จำเป็นต้องปรับเองได้บ้าง ผู้ใช้งานจะต้องเรียนรู้มาเองก่อนตามลำดับ ติดตรงไหนแล้วสามารถถามมาได้เรือ่ย ๆ ครับ

snasui wrote: ลองปรับให้ Clear มาเองก่อนครับ ปรับแล้วติดตรงไหนสามารถถามมาได้เรือย ๆ ครับ

snasui wrote: แนบ Code มาพร้อมไฟล์ จะได้ช่วยทดสอบได้ครับ

snasui wrote: ตัวอย่าง Code ตามด้านล่างครับ

Code: Select all

Sub DataM()
    Dim r1 As Range, r2 As Range
    Dim rTarget As Range
    With Sheets("¡ÐàªéÒ")
        Set r1 = .Range("a30:g30")
        Set r2 = .Range("b9:j16")
    End With
    With Sheets("DataM")
        Set rTarget = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
        r1.Copy
        rTarget.Resize(r2.Rows.Count).PasteSpecial xlPasteValues
        r2.Copy
        rTarget.Offset(0, r1.Columns.Count).PasteSpecial xlPasteValues
    End With
    r2.ClearContents '<== this line for clear contents
    Application.CutCopyMode = True
End Sub

Tahiti80s wrote:

snasui wrote: ตัวอย่าง Code ตามด้านล่างครับ

Code: Select all

Sub DataM()
    Dim r1 As Range, r2 As Range
    Dim rTarget As Range
    With Sheets("¡ÐàªéÒ")
        Set r1 = .Range("a30:g30")
        Set r2 = .Range("b9:j16")
    End With
    With Sheets("DataM")
        Set rTarget = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
        r1.Copy
        rTarget.Resize(r2.Rows.Count).PasteSpecial xlPasteValues
        r2.Copy
        rTarget.Offset(0, r1.Columns.Count).PasteSpecial xlPasteValues
    End With
    r2.ClearContents '<== this line for clear contents
    Application.CutCopyMode = True
End Sub

ขอบคุณอาจารย์มากๆครับ

snasui wrote: Code นั้นแค่ลบค่าในเซลล์ทิ้งไป ไม่ได้ Cut ครับ

สำหรับการปรับปรุง Code ต้องปรับปรุงมาเอง ติดแล้วค่อยถาม ไม่สามารถถามต่อเนื่องโดยไม่ผ่านการลองปรับมาเองในสิ่งที่ต้องการเพิ่มเติมจากเดิมครับ

Sub Button7_Click()
    Dim r1 As Range, r2 As Range
    Dim rTarget As Range
    With Sheets("¡ÐàªéÒ")
        Set r1 = .Range("a30:g30")
        Set r2 = .Range("b9:j16")
    End With
    With Sheets("DataM")
        Set rTarget = .Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
        r1.Copy
        rTarget.Resize(r2.Rows.Count).PasteSpecial xlPasteValues
        r2.Copy
        rTarget.Offset(0, r1.Columns.Count).PasteSpecial xlPasteValues
    End With
     With rTarget
      On Error Resume Next
         With .Range(r2).Cells.SpecialCells(xlCellTypeConstants)
             .ClearContents
             Application.Goto .Cells(1) ', Scroll:=True
         End With
      On Error GoTo 0
    End With
    r2.ClearContents
    Application.CutCopyMode = True
End Sub