ต้องการบันทึกข้อมูลใหม่ ให้อยู่ด้านบนเสมอ

[liveday]

เรียน อาจารย์ทุกท่าน

ผมต้องการบันทึกข้อมูลใหม่ ให้อยู่ด้านบนเสมอ ต้องทำอย่างไรครับ

ขอบคุณครับ

[puriwutpokin]

ลองปรับเป็น

Code: Select all

Sub Paste()
    Dim irRange As Variant
    Dim i As Integer, rw As Long
    irRange = Array("B9", "B10", "B11", _
        "B12", "B13", "B15", "B16", _
        "B17", "B18", "B19", "B20", "B21", _
        "B22", "B23", "B24", "B25", "B26")
    rw = Worksheets("Database").Range("b" & Rows.Count).End(xlUp).Row + 1
    For i = 0 To UBound(irRange)
        With Worksheets("Database")
            .Range("b" & rw).Offset(0, i).Value = Sheets("Input").Range(irRange(i)).Value
        End With
    ActiveWorkbook.Worksheets("Database").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Database").Sort.SortFields.Add Key:=Range("D3:D3") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Database").Sort
        .SetRange Range("A3:R1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Next i
End Sub

[liveday]

ลองปรับเป็น

Code: Select all

Sub Paste()
    Dim irRange As Variant
    Dim i As Integer, rw As Long
    irRange = Array("B9", "B10", "B11", _
        "B12", "B13", "B15", "B16", _
        "B17", "B18", "B19", "B20", "B21", _
        "B22", "B23", "B24", "B25", "B26")
    rw = Worksheets("Database").Range("b" & Rows.Count).End(xlUp).Row + 1
    For i = 0 To UBound(irRange)
        With Worksheets("Database")
            .Range("b" & rw).Offset(0, i).Value = Sheets("Input").Range(irRange(i)).Value
        End With
    ActiveWorkbook.Worksheets("Database").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Database").Sort.SortFields.Add Key:=Range("D3:D3") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Database").Sort
        .SetRange Range("A3:R1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Next i
End Sub

ได้นำมาใช้ ผลลัพท์ยังเหมือนเดิม ข้อมูลยังเรียงลำดับจากบนไปล่างอยู่ครับ

[puriwutpokin]

ใช่ผลลัพธ์ตามไฟล์แนบหรือไม่ ครับ

[liveday]

ใช่ผลลัพธ์ตามไฟล์แนบหรือไม่ ครับ

ถ้าเป็นการคีย์ข้อมูลเข้าไปใหม่ได้ครับ แต่ถ้ามีข้อมูลเก่าที่มีอยู่แล้วพอนำมาใช้งาน ยังไปอยู่บรรทัดล่างเหมือนเดิมครับ

[puriwutpokin]

ไม่ได้ใจได้เป็นช่วงของข้อมูลตาม ข้อมูลจริงหรือเปล่าครับ

Code: Select all

.SetRange Range("A3:R1000")

[liveday]

ใช้กับข้อมูลเก่าครับ พอบันทึกจะไปอยู่ด้านล่างเหมือนเดิมครับ

[puriwutpokin]

ลองปรับตามนี้ครับ

Code: Select all

Sub Paste()
    Dim irRange As Variant
    Dim i As Integer, rw As Long
    irRange = Array("B9", "B10", "B11", _
        "B12", "B13", "B15", "B16", _
        "B17", "B18", "B19", "B20", "B21", _
        "B22", "B23", "B24", "B25", "B26")
      Sheets("Database").Select
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Input").Select
    rw = Worksheets("Database").Range("B3").Row
    For i = 0 To UBound(irRange)
        With Worksheets("Database")
            .Range("b" & rw).Offset(0, i).Value = Sheets("Input").Range(irRange(i)).Value
        End With
    Next i
End Sub

[liveday]

ได้ตามต้องการครับ ขอบคุณมากครับ