Code วางเรียงตามอักษรค่ะ

[suka]

เรียนอาจารย์และท่านผู้รู้ช่วยปรับโค้ดค่ะ
ตัวอย่างไฟล์ Form.xlsm ชีท Form เซลล์ B5 ดึงค่าสุดท้ายจากชีท Alphabetize อักษรตามในเซลล์ A5 ไปวางไฟล์ CusID_Share.xlsx ชีท Sheet1 คอลัมน์ B เรียงต่อท้ายตามอักษรค่ะ

โค้ดติด E = .Sheets("Sheet1").Range("b" & Rows.Count).End(xlUp).Value + 1 นี้ค่ะ
ฟ้องตามรูปแนบค่ะ

Code: Select all

Sub PasteData()
        Dim wbShare As Workbook
        Dim formBook As Workbook
        Dim rTarget As Range
        Dim E As Long
        Dim rs As Range
        Dim rt As Range
        Set formBook = ThisWorkbook
        Set wbShare = Workbooks("CusID_Share.xlsx")
        With wbShare
            E = .Sheets("Sheet1").Range("b" & Rows.Count).End(xlUp).Value + 1
            Select Case formBook.Sheets("Form").Range("a5").Value
                Case "ก"
                    E = formBook.Sheets("Alphabetize").Range("c2")
                  Case "ข"
                    E = formBook.Sheets("Alphabetize").Range("c3")
                Case "ค"
                    E = formBook.Sheets("Alphabetize").Range("c4")
            End Select
        formBook.Worksheets("Form").Range("b5").Value = E
        End With
       
         wbShare.Save
         
        With formBook.Worksheets("Form")
             Set rs = .Range("A5:C5")
        End With
        Set rt = wbShare.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        rs.Copy: rt.PasteSpecial xlPasteValues
        formBook.Activate
End Sub

[snasui]

หากต้องการหาค่าบรรทัดให้เปลี่ยน .value เป็น .row ครับ

[suka]

ปรับโค้ดนี้เป็น E = .Sheets("Sheet1").Range("b" & Rows.Count).End(xlUp).Row + 1

แล้วมาติดตรงโค้ด E = formBook.Sheets("Alphabetize").Range("c2") นี้ค่ะ ควรปรับแก้โค้ดนี้อย่างไรดีคะ

[suka]

อาจารย์คะได้ปรับ
E = formBook.Sheets("Alphabetize").Range("c2")
เป็น
E = formBook.Sheets("Alphabetize").Range("c2").Row

ยังติดปัญหาที่ตัวอย่างไฟล์ CusID_Share.xlsx ชีท Sheet1 ระบายสีแดงโค้ดวางตัวเลขแค่หลักเดียวและไม่ +1 เพิ่มค่ะ

ความต้องการที่ตัวอย่างไฟล์ CusID_Share.xlsx ชีท Sheet1 ระบายสีเหลืองค่ะ

[puriwutpokin]

ลองปรับเป็น

Code: Select all

Sub PasteData()
        Dim wbShare As Workbook
        Dim formBook As Workbook
        Dim rTarget As Range
        Dim E As Long
        Dim rs As Range
        Dim rt As Range
        Set formBook = ThisWorkbook
        Set wbShare = Workbooks("CusID_Share.xlsx")
        With wbShare
            E = .Sheets("Sheet1").Range("b" & Rows.Count).End(xlUp).Row + 1
            Select Case formBook.Sheets("Form").Range("a5").Value
                Case "ก*"
                    E = formBook.Sheets("Alphabetize").Range("c2")
                  Case "ข*"
                    E = formBook.Sheets("Alphabetize").Range("c3")
                Case "ค*"
                    E = formBook.Sheets("Alphabetize").Range("c4")
            End Select
       ' formBook.Worksheets("Form").Range("b5").Value = E
        End With
       
         wbShare.Save
         
        With formBook.Worksheets("Form")
             Set rs = .Range("A5:C5")
        End With
        Set rt = wbShare.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        rs.Copy: rt.PasteSpecial xlPasteValues
        formBook.Activate
End Sub

[suka]

ขอบคุณคุณ puriwutpokin มากค่ะ โค้ดทำงานได้ตรงตามที่ต้องการเลยค่ะ

[suka]

ขอความช่วยเหลือค่ะ เรื่องการปรับโค้ดมีเซลล์ที่ Merge ต้องการเคลียร์ล้างข้อมูล ไม่สามารถล้างข้อมูลเนื่องจากมี Merge เซลล์ค่ะ ติดโค้ดด้านล่างนี ใช้กับโค้ดชื่อ PasteData อยู่ Module1 ควรปรับอย่างดีคะ
formBook.Sheets("Form").Range("B8:G8,C10(),C11,C12:G16").ClearContents

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Dim rng As Range
'Other code
For Each rng In formBook.Sheets("Form").Range("B8:G8,C10,C11,C12:G16")
    If rng.MergeCells Then
        rng.MergeArea.ClearContents
    Else
        rng.ClearContents
    End If
Next rng
'Other code

[suka]

ขอบคุณค่ะอาจารย์ โค้ดได้ตรงตามต้องการแล้วค่ะ