ถามเกี่ยวกับ Marcro ครับ

[Tahiti80s]

สอบถามเกี่ยว การ เขียนโค๊ด VBA ครับ ถ้าเราต้องการให้ มาโครข้อมูล ไปไว้อีก ชีส แต่ไฟล์ที่ได้มันเป็นลักษณะ แนวนอนครับ อยากให้ข้อมูลที่Copyไปอีก Sheet ไปเป็นลักษณะแนวตั้ง เหมือนกับตอนทที่ยังไม่ก๊อบปี้ ต้องเขียนโค้ด อย่างไรบ้าง คือผมก็ไม่ค่อยมีความรู้เกี่ยวกับ VBA เท่าไหร่ครับ รบกวนด้วยครับ ขอบคุณมากครับ รายละเอียดตามไฟลที่แนบไปครับผม

[snasui]

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

[Tahiti80s]

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

ตัวอย่างตามไฟล์ที่แนบไปข้างต้นครบอาจารย์

[snasui]

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

[Tahiti80s]

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

ต้องการให้ข้อมูล Sheet กะเช้า ครับ ในตารางทั้งหมดครับ อยากให้กด Command Box แล้วส่งค่าไปที่ Sheet DataM ครับ ปกติส่งค่าไปได้แต่ มันเป็นลักษณะแนวนอน ตามไฟล์ ที่แนบไปครับ อาจารย์ อยากให้ข้อมูลเป็นลักษณะแนวตั้ง ครับ ต้องแก้โค๊ดอย่างไรบ้างครับ

[Tahiti80s]

สอบถามอาจารย์เพิ่มเติมครับ อาจารย์เปิดสอน Excel หรือเปล่าครับ

[snasui]

ลองปรับ 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]

ลองปรับ 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]

ลองปรับ 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

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

อาจารย์ครับจะประยุกต์ใช้ยังไงครับ พอดีผมยังไม่ค่อยเข้าใจเกี่ยวกับ Code VBA ผมก็ก๊อบมาลองผิดลองถูก แต่ยังไม่เข้าใจหลักการ เลยไปต่อไม่ได้ครับ ขอบคุณครับ

[snasui]

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

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

[Tahiti80s]

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

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

อาจารย์ครับ ติดตรงที่ตารางที่เรากรอกมัน ไม่ ทำการ Clear ครับ อาจารย์ ไม่ทราบว่าใช้คำสั่ง อะไรครับ ขอบคุณครับๆ

[snasui]

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

[Tahiti80s]

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

ลองปรับดูตามนี้ไม่รู้ถูกหรอป่าว ผมยงังงๆครับ แต่ไม่ได้ -*- ต้องใส่เพิ่มเติมอย่างไรบ้างครับ ขอบคุณรับ
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
Application.CutCopyMode = True
'clear input cells that contain constants
With rTarget
On Error Resume Next
With .Range(rTarget).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.Goto .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
'clear input cells that contain constants
With rTarget
On Error Resume Next
With .Range(rTarget).SpecialCells(xlCellTypeConstants).ClearContents

Application.Goto .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With


End Sub

[snasui]

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

[Tahiti80s]

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

รบกวนอาจารย์ด้วยครับ
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
Application.CutCopyMode = True

'clear input cells that contain constants
With rTarget
On Error Resume Next
With .Range(rTarget).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.Goto .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With

End Sub

[snasui]

ตัวอย่าง 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]

ตัวอย่าง 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]

ตัวอย่าง 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

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

รบกวนอาจารย์อีกเรื่องครับ พอมัน Cut ไปหมดจริง สูตรมันก็ Cut ไปด้วยครับ ต้องแก้ไขตรงไหนครับ อาจารย์ ขอบคณครับ

[snasui]

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

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

[Tahiti80s]

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

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

Code: Select all

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

    

พยายามปรับโค้ดแล้วครับ มันก็ยังก๊อบปี้คัตสูตรไปหมดเลยครับ รบกวนอาจารย์ช่วยหน่อยครับ ขอบคุณครับ