Snasui Excel Forum

Posted: **Mon Feb 04, 2019 1:52 pm**

สวัสดีปีใหม่จีนค่ะ

ขอความช่วยเหลือในการเขียนโค้ด 2 เรื่องค่ะ
1. การก๊อปปี้จากคอลัมน์จากชีท "Itemize" เพื่อไปวางที่ชีท "FINAL ITEMIZE" โค้ดนี้เมื่อใช้งานจำนวนที่มากๆ ทำให้เครื่องทำงานช้าผิดปกติ ไม่ทราบว่ามีโค้ดที่ทำให้ข้อมูลวางได้ไวกว่านี้หรือไม่คะ (ดึงมาเป็นบางคอลัมน์ค่ะ)
2. ต้องการให้แสดงชื่อโรค โดยไม่เป็นการกำหนด Range ที่ 30 อยากให้ดึงตามข้อมูลที่มีอยู่ เช่น ที่ชีท "FINAL ITEMIZE" จบที่ 17 ก็ให้จบที่ 17
และต้องการทำให้เป็น pastespecialvalue ค่ะ

มือใหม่ ขอขอบพระคุณล่วงหน้าค่ะ

Code: Select all

Private Sub CommandButton5_Click()
Dim Ir, erow As Integer
Ir = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row

For i = 7 To Ir
    erow = Sheet7.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Sheet5.Cells(i, 1).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 1)

    Sheet5.Cells(i, 2).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 2)
    
    Sheet5.Cells(i, 3).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 3)
    
    Sheet5.Cells(i, 4).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 4)
    
    Sheet5.Cells(i, 5).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 5)
    
    Sheet5.Cells(i, 8).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 6)
    
    Sheet5.Cells(i, 9).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 7)
    
    Sheet5.Cells(i, 10).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 8)
    
    Sheet5.Cells(i, 11).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 9)
    
    Sheet5.Cells(i, 12).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 10)
    
    Sheet5.Cells(i, 13).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 11)
    
    Sheet5.Cells(i, 46).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 12)
    
    Sheet5.Cells(i, 47).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 13)
    
    Sheet5.Cells(i, 17).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 14)
    
    Sheet5.Cells(i, 18).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 15)
    
    Sheet5.Cells(i, 22).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 16)
        
    Sheet5.Cells(i, 26).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 17)
    
    Sheet5.Cells(i, 27).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 18)
    
    Sheet5.Cells(i, 32).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 19)
        
    Sheet5.Cells(i, 33).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 20)
    
    Sheet5.Cells(i, 39).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 21)
    
    Sheet5.Cells(i, 40).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 22)
    
    Sheet5.Cells(i, 41).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 23)
    
    Sheet5.Cells(i, 42).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 24)
    
    Sheet5.Cells(i, 44).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 25)
    
    Sheet5.Cells(i, 45).Copy
    Sheet5.Paste Destination:=Worksheets("FINAL ITEMIZE").Cells(erow, 26)
Next i
Application.CutCopyMode = False
Sheet7.Columns().AutoFit
Range("A1").Select
End Sub

Code: Select all

Option Explicit

Sub Diagnosis()

Worksheets("FINAL ITEMIZE").Activate
Range("AA7") = "Diagnosis (Thai)"
Range("AA8").Select
ActiveCell.FormulaR1C1 = _
  "=IFERROR(VLOOKUP(LEFT(RC[-6],4),'ICD10'!C[-25]:C[-23],2,0),VLOOKUP(LEFT(RC[-6],3),'ICD10'!C[-25]:C[-23],2,0))"
  Selection.Copy
  
 
  Range(Selection, Selection.End(xlDown)).Select
  Range("AA8:AA30").Select
  'Range("AA" & Rows.Count).End(xlUp).Select
   ActiveSheet.Paste
  
  
  Columns("AA:AA").EntireColumn.AutoFit
  'Range("AA").PasteSpecial Paste:=xlPasteValues


  
  Application.CutCopyMode = False
End Sub

Posted: **Mon Feb 04, 2019 5:30 pm**

ลองปรับเป็น

Code: Select all

Private Sub CommandButton5_Click()
Dim Ir, erow As Integer
Application.ScreenUpdating = False
Ir = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
For i = 7 To Ir
    erow = Sheet7.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Sheet5.Cells(i, 1).Resize(, 5).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 1).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 8).Resize(, 6).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 6).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 46).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 12).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 17).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 14).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 22).Resize(, 1).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 16).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 26).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 17).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 32).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 19).PasteSpecial xlPasteValues
    Sheet5.Cells(i, 39).Resize(, 5).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 21).PasteSpecial xlPasteValues
     Sheet5.Cells(i, 44).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 25).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheet7.Columns().AutoFit
Range("A1").Select
End Sub

Posted: **Tue Feb 05, 2019 10:04 am**

ขอบพระคุณอาจารย์มากค่ะ ได้แก้ไขและจะนำไปใช้ประโยชน์ได้อีกหลายรายงานเลยค่ะ

สำหรับปัญหาที่ติดข้อ 2 ลองปรับโค้ดแล้วแต่ยังติดค่ะ รบกวนช่วยปรับให้หน่อยค่ะ

ที่โมดูลย์ 1 ต้องการหาข้อมูลโรคจากคอลัมน์ U ค่ะติดตรงเมื่อ Vlookup แล้วรายการที่ไม่มีต้องการให้แสดง "Not Found" และอยากปรับให้เป็น PasteSpecialValue ค่ะ

ขอบคุณค่ะ

Code: Select all

Option Explicit

Sub Diagnosis()
Worksheets("FINAL ITEMIZE").Activate
On Error GoTo Polly:


Dim i As Long
Range("AA7") = "Diagnosis (Thai)"

For i = 1 To Range("U10000").End(xlUp).Row - 7
Range("AA" & i + 7).Value = "=IFERROR(VLOOKUP(LEFT(RC[-6],4),'ICD10'!C[-25]:C[-23],2,0),VLOOKUP(LEFT(RC[-6],3),'ICD10'!C[-25]:C[-23],2,0))"
Next
Exit Sub

Polly:
  Range("AA" & i + 7).Value = "NOT FOUND"
  Resume Next
End Sub

Posted: **Tue Feb 05, 2019 11:06 am**

ปรับตรงส่วนนี้ครับ

Code: Select all

'Other code...
Range("AA" & i + 7).Value = "=IFERROR(IFERROR(VLOOKUP(LEFT(RC[-6],4),'ICD10'!C[-25]:C[-23],2,0),VLOOKUP(LEFT(RC[-6],3),'ICD10'!C[-25]:C[-23],2,0)),""NOT FOUND"")"
'Other code...

Posted: **Tue Feb 05, 2019 11:12 am**

อาจารย์คะ ตรงโค้ดแรกที่ก๊อปปี้คอลัมน์มาค่ะ พบว่าวันที่ที่ก๊อปมาเป็นตัวเลข 6 หลักต้องการ Format Date ที่เป็นตามต้นฉบับค่ะ เช่น 01-04-2562
รบกวนด้วยอีกครั้งค่ะ ขอบคุณค่ะ

Posted: **Tue Feb 05, 2019 11:32 am**

อาจารย์คะ

ทำได้แล้วค่ะ ปรับแก้ตรง PasteSpecial เฉยๆ ขอบคุณมากค่ะ

Posted: **Tue Feb 05, 2019 11:34 am**

Polly wrote: Tue Feb 05, 2019 11:12 am อาจารย์คะ ตรงโค้ดแรกที่ก๊อปปี้คอลัมน์มาค่ะ พบว่าวันที่ที่ก๊อปมาเป็นตัวเลข 6 หลักต้องการ Format Date ที่เป็นตามต้นฉบับค่ะ เช่น 01-04-2562
รบกวนด้วยอีกครั้งค่ะ ขอบคุณค่ะ

้ข้อ 2 แก้ไขเป็นค่าใช่ไหมครับ
ปรับเป็น

Code: Select all

'Other code...
For i = 1 To Range("U10000").End(xlUp).Row - 7
With Range("AA" & i + 7)
.Value = "=IFERROR(IFERROR(VLOOKUP(LEFT(RC[-6],4),'ICD10'!C[-25]:C[-23],2,0),VLOOKUP(LEFT(RC[-6],3),'ICD10'!C[-25]:C[-23],2,0)),""NOT FOUND"")"
.Value = .Value
End With
Next
'Other code...

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

Posted: **Wed Feb 06, 2019 5:25 pm**

สวัสดีค่ะ

สำหรับที่ก๊อปปี้มาที่เป็นเรื่องวันที่ จะอยู่ที่ชีท "Itemize" คอลัมน์ที่ 32-33 (จะเป็นข้อมูลวันที่) หนูปรับเองตามโค้ดข้างล่าง พอได้ไหมคะ
สำหรับที่ให้อาจารย์ช่วยปรับค่าให้เป็น value หลังจาก vlookup เป็นตามที่ต้องการแล้วค่ะ

ขอบพระคุณมากค่ะอาจารย์

Code: Select all

Sheet5.Cells(i, 32).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 19).PasteSpecial

Posted: **Wed Feb 06, 2019 6:11 pm**

ถ้าไม่format เอาทั้งหมดก็ปรับตรงนี้ครับ

Code: Select all

Sheet5.Cells(i, 32).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 19).PasteSpecial(xlPasteAll)

Posted: **Wed Feb 06, 2019 7:16 pm**

Polly wrote: Wed Feb 06, 2019 5:25 pm สวัสดีค่ะ

สำหรับที่ก๊อปปี้มาที่เป็นเรื่องวันที่ จะอยู่ที่ชีท "Itemize" คอลัมน์ที่ 32-33 (จะเป็นข้อมูลวันที่) หนูปรับเองตามโค้ดข้างล่าง พอได้ไหมคะ
สำหรับที่ให้อาจารย์ช่วยปรับค่าให้เป็น value หลังจาก vlookup เป็นตามที่ต้องการแล้วค่ะ

ขอบพระคุณมากค่ะอาจารย์
Code: Select all
Sheet5.Cells(i, 32).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 19).PasteSpecial

ปรับเป็นโค้ดนี้ดีกว่าครับ เผื่อข้อมูลต้นทางมีค่าสี ที่ไม่ต้องการ หรืออะไร เช่นเส้นบรรทัดจะได้ไม่ต้องเอามาด้วยครับ

Code: Select all

Sheet5.Cells(i, 32).Resize(, 2).Copy
    Worksheets("FINAL ITEMIZE").Cells(erow, 19).PasteSpecial xlPasteValuesAndNumberFormats

Posted: **Thu Feb 07, 2019 11:28 am**

ทำได้สำเร็จเพราะอาจารย์เลยค่ะ ขอบพระคุณมากสำหรับความช่วยเหลือค่ะ

Snasui Excel Forum

การก๊อปปี้คอลัมน์ และ Range

การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range

Re: การก๊อปปี้คอลัมน์ และ Range