วางข้อมูลที่คัดลอกให้ตรงตามเลขที่

[pongpang]

เรียน อาจารย์และสมาชิก ทุกท่าน
ด้วยต้องการ
1.คัดลอกข้อมูลตั้งแต่ C5 ถึง H14 ที่ข้อมูล
2.นำข้อมูลที่คัดลอกวาง ที่ U3 ถึง Z ให้ตรงตามเลขที่
ซึ่งได้ใช้ Code ดังนี้ ครับ

Code: Select all

Sub Macro6()
    Application.ScreenUpdating = False
    Dim FormWs As Worksheet
    Dim lngLastRow As Long
    Dim lngPosition As Long
    Dim lr As Long
    Set FormWs = Sheets("sheet1")
    lngLastRow = FormWs.Range("C" & Rows.Count).End(xlUp).Row
    FormWs.Range("C5:H14" & lngLastRow).Copy
    With Worksheets("sheet1")
        lngRowNum = Application.WorksheetFunction.CountIf( _
            .Range("U3:U" & .Range("U65536").End(xlUp).Row), Sheets("Sheet1").Range("U3"))
        If lngRowNum = 0 Then
            Sheets("sheet1").Range("U65536").End(xlUp).Offset(1, 0) _
                .PasteSpecial xlPasteValues, Transpose:=True
        Else
        With Worksheets("sheet1")
            lngPosition = Application.WorksheetFunction.Match( _
                Sheets("Sheet1").Range("c5"), .Range("U3:U" & .Range("U" & Rows.Count) _
                .End(xlUp).Row), 0)
            Sheets("sheet1").Range("U" & (2 + lngPosition)) _
                .PasteSpecial xlPasteValues, Transpose:=True  'เลข2+inPosition คือ จำนวนแถวก่อนวางข้อมูล
            End With
        End If
        With Worksheets("sheet1")
            lr = .Range("U" & Rows.Count).End(xlUp).Row
            Set irRange = Sheets("sheet1").Range("U3:Z" & lr)
            irRange.Borders.LineStyle = xlContinuous
            irRange.Sort Key1:=Sheets("sheet1").Range("U3"), _
                Order1:=xlAscending, Header:=xlGuess
        End With
    End With
    Sheets("sheet1").Range("K5:P14").Select
    Selection.Copy
    Sheets("sheet1").Range("C5").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

แต่วางข้อมูลได้ไม่ตรงตามที่ต้องการ ขอความกรุณาให้ความอนุเคราะห์แก้ไข Code ให้ด้วยครับ

วางข้อมูลได้ตรงตามเลขที่.xlsm

[snasui]

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

Code: Select all

Dim rAll As Range, r As Range
Dim f As Long, i As Integer
With Sheets("Sheet1")
    If .Range("c5").Value = "" Then End
    Set rAll = .Range("c5:c100").SpecialCells(xlCellTypeFormulas, 1)
    For Each r In rAll
        f = Application.CountIf(.Range("u3:u1000"), r.Value)
        If f > 0 Then
            i = Application.Match(r.Value, .Range("u3:u1000"), 0)
            .Range("u3:u1000")(i).Resize(1, 6).Value = r.Resize(1, 6).Value
        End If
    Next r
End With

[pongpang]

เรียน อาจารย์ snasui พร้อมกับ อาจารย์ ท่านอื่น และ สมาชิก ทุกท่าน
ได้ตามที่ต้องการครับ ขอบคุณมากครับ

[pongpang]

เรียน อาจารย์ snasui พร้อมกับ อาจารย์ ท่านอื่น และ สมาชิก ทุกท่าน
ผมมีความบกพร่องในการขอความช่วยเหลือจากอาจารย์ ครั้งก่อน ไม่รอบคอบทำให้ไม่สมบูรณ์ ครับ ขออภัยด้วยครับ
จากการที่อาจารย์ให้การช่วยเหลือ ดังนี้ คือ

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

Code: Select all

Dim rAll As Range, r As Range
Dim f As Long, i As Integer
With Sheets("Sheet1")
    If .Range("c5").Value = "" Then End
    Set rAll = .Range("c5:c100").SpecialCells(xlCellTypeFormulas, 1)
    For Each r In rAll
        f = Application.CountIf(.Range("u3:u1000"), r.Value)
        If f > 0 Then
            i = Application.Match(r.Value, .Range("u3:u1000"), 0)
            .Range("u3:u1000")(i).Resize(1, 6).Value = r.Resize(1, 6).Value
        End If
    Next r
End With

ปัญหาคือ ถ้าเพิ่มสมาชิกใหม่ จะไม่สามารถเพิ่มได้ จะเออเร่อ ตามภาพครับ

Debug.JPG

จึงขอความกรุณา อาจารย์ช่วยแนะนำเพิ่มเติมให้สามารถเพิ่มสมาชิกได้ด้วยครับ และขออภัยที่ครั้งก่อนคำถามไม่ครอบคลุมชัดเจน ครับ

วางข้อมูลได้ตรงตามเลขที่ครั้งที่2.xlsm

[snasui]

ตามไฟล์ที่แนบมานั้นผมไม่พบว่ามี Error และหากมี Error เกิดขึ้นจริงให้ลองปรับเพื่อแก้ Error มาก่อน ติดตรงไหนค่อยถามกันต่อ ไม่ควรนำ Code เดิมที่ยังไม่ปรับมาถามกันครับ