วิธีเลือกCopyและเจาะจงวางเฉพาะเซล หลายตำแหน่ง ในคราวเดียวกัน โดย VBA

[psnorth]

ผมต้องการเลือกข้อมูล ข้อมูลช่อง d2,d3,e2,e3,e4 ไปวางไว้อีกชีทนึง ในช่อง d,b,g,j,l,m โดยที่ทุกครั้งที่ใส่ข้อมูลใหม่ จะขึ้นแถวใหม่ให้ โค๊ดที่ผมพยามเขียนทำงานได้ แต่ช้ามากกก ขนาดดึงข้อมูลแค่2ตัวเอง
รบกวนอาจารย์หรือท่านผู้มีความรู้ทำเป็นโค๊ดที่ถูกต้องด้วยครับ

โหลดไฟจากนี้นะครับ ผมลอง attachments แต่ไม่ได้
https://docs.google.com/uc?authuser=0&i ... t=download

หรือโค๊ดตามนี้ครับ

Code: Select all

Sub sent()
Dim Sheet As Sheet1
Range("d5").Copy
Sheets("Sheet1").Select
Range("b65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("inform").Select
Range("d6").Copy
Sheets("Sheet1").Select
Range("d65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues

End Sub

[psnorth]

แก้เป็นแบบนี้แทนครับ

Code: Select all

Sub sent()
Dim sheet As Worksheets

Range("d5").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(1, 0)
Range("d6").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 2)
Range("f6").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 5)
Range("f7").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 9)
Range("f8").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 13)
Range("f9").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 17)
Range("f10").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 21)
Range("f11").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 25)
Range("f12").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 29)
Range("f13").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 33)
Range("f14").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 37)
Range("f15").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 41)
Range("i6").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 45)
Range("i7").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 49)
Range("i8").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 53)
Range("k6").Copy Destination:=Sheets("sheet1").Range("b65536").End(xlUp).Offset(0, 57)
End Sub

แต่ก็ยังช้าอยู่ดี รบกวนช่วยแนะนำด้วยครับ
https://drive.google.com/file/d/0B72NbU ... sp=sharing

[DhitiBank]

แนบไฟล์ได้ครับ แต่ต้องตั้งชื่อไฟล์เป็นภาษาอังกฤษ หรือปรับให้ไฟล์มีขนาดเล็กลงโดยลบข้อมูลให้เหลือเพียงตัวอย่าง

ทดลองดูแบบนี้ครับ

Code: Select all

Sub sent()
   Dim sheet1 As Worksheet, shInput As Worksheet
   Dim lRow As Long
   
   Set sheet1 = Sheets("sheet1")
   Set shInput = Activesheet
   '//หา first blank row ในตารางข้อมูล
   lRow = sheet1.Range("b"&Rows.Count).End(xlUp).Offset(1,0).Row
   '//สั่งหยุดการคำนวณอัตโนมัติ และอื่นๆ
   With Application
      .EnableEvents=False
      .Calculation=xlCalculationManual
      .ScreenUpdating=False
   End With
   With sheet1
      .Cells(lRow,"b").Value=shInput.Range("d5")
      '// ถัดจากบรรทัดนี้ คุณก็พิมพ์เหมือนบรรทัดบน _
      เพียงเปลี่ยนอักษรในเครื่องหมาย " " ด้านซ้าย _
      เป็นคอลัมน์ปลายทาง และเปลี่ยนเซลล์ใน _
      เครื่องหมาย " " ด้านขวา เป็นเซลล์มี่มีข้อมูลต้นทาง _
      ลองดูครับ
   End With
   '//เปิดการคำนวณอัตโนมัติและอื่นๆ
   With Application
      .Calculation=xlCalculationAutomatic
      .EnableEvents=True
      .ScreenUpdating=True
   End With
End Sub

[psnorth]

ขอบพระคุณมากเลยจริงๆครับ ดีใจมากเลย^^