VBA ย้ายข้อมูล Row ถัดไปไปต่อ Column สุดท้าย ของ Row ก่อนหน้า

[JackapongT]

สวัสดีครับ

ผมกำลังทำฟอร์มชุดข้อมูล ที่แปลงจาก .csv และมีปัญหาเรื่องการทำชุดข้อมูลที่ได้รับจากไฟล์ดิบที่มีปัญหาเกี่ยวกับ Row ของข้อมูลเนื่องจากใน แต่ละ Row จะมีตัวอักษรอักขระขึ้นนำ และจะต้องเป็นตัวอักษรตามตัวอย่างที่แนบมา ซึ่งมีหลายพัน Row
เบื้องต้นผมได้ลองใช้ VBA+Macro เพื่อให้มีการ Cut copy paste และ Shift row up ขึ้นมาทีละบรรทัด หากต้องการ ให้ทำได้หลายๆบรรทัดจะต้องเขียน โค้ดในลักษณะนี้ หลายพันบรรทัดมาก และ ต้อง Call function จาก sub หลายๆรอบ ช่วยแนะนำหน่อยครับ ว่าควรตั้ง Loop อย่างไร

ผมได้แนบไฟล์ที่มีการเขียน Macro ไว้ และมีปุ่ม Set กับ Restart ไว้ลองโปรแกรมครับ

Code: Select all

Sub SETN()
    
    ''Set N for 1st row------------------------------------------------------------------------------------------------
    If Range("A2") = "" Then
        Rows("2:2").Select
        Selection.Delete Shift:=xlUp
    Else
        If Left(Range("A2"), 1) <> "N" Then
            Range("A2").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Cut
 
            Range("A1").Select
            Range("A1").End(xlToRight).Offset(0, 1).Select

            ActiveSheet.Paste
            Rows("2:2").Select
            Selection.Delete Shift:=xlUp
    Else
        
    ''Set N for 2nd row------------------------------------------------------------------------------------------------
    If Range("A3") = "" Then
        Rows("3:3").Select
        Selection.Delete Shift:=xlUp
    Else
        If Left(Range("A3"), 1) <> "N" Then
            Range("A3").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Cut
            'Need next cell fomular here '
            Range("A2").Select
            Range("A2").End(xlToRight).Offset(0, 1).Select
            'Need next cell fomular here '
            ActiveSheet.Paste
            Rows("3:3").Select
            Selection.Delete Shift:=xlUp
    Else
    
    ''Set N for 3rd row------------------------------------------------------------------------------------------------
    If Range("A4") = "" Then
        Rows("4:4").Select
        Selection.Delete Shift:=xlUp
    Else
        If Left(Range("A4"), 1) <> "N" Then
            Range("A4").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Cut
            'Need next cell fomular here '
            Range("A3").Select
            Range("A3").End(xlToRight).Offset(0, 1).Select
            'Need next cell fomular here '
            ActiveSheet.Paste
            Rows("4:4").Select
            Selection.Delete Shift:=xlUp
     Else
    
    ''Set N for 4th row------------------------------------------------------------------------------------------------
    If Range("A5") = "" Then
        Rows("5:5").Select
        Selection.Delete Shift:=xlUp
    Else
        If Left(Range("A5"), 1) <> "N" Then
            Range("A5").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Cut
            'Need next cell fomular here '
            Range("A4").Select
            Range("A4").End(xlToRight).Offset(0, 1).Select
            'Need next cell fomular here '
            ActiveSheet.Paste
            Rows("5:5").Select
            Selection.Delete Shift:=xlUp
    
    End If
    End If
    End If
    End If
    End If
    End If
    End If
    End If

    
End Sub

[Bo_ry]

VBA

Code: Select all

Private Sub CommandButton1_Click()
Dim rn As Range, a(1 To 99, 9999), r&, c&
For Each rn In [A1].CurrentRegion
    If Application.IsText(rn.Value2) Then
        r = r + 1: c = 0
        a(r, c) = rn.Value2
    ElseIf rn.Value2 <> "" Then
        c = c + 1: a(r, c) = rn.Value2
    End If
Next
[A1].CurrentRegion.ClearContents
[A1].Resize(r, 9999) = a
End Sub

Private Sub CommandButton2_Click()
    Sheets("Sheet2").Range("A1:U30").Copy [A1]
End Sub

Power Query

Code: Select all

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Grouped = Table.Group(Source, "Column1", {{"T", each (_)}},0,(b,e)=> Number.From(Text.Start(Text.From(e),1)="N")),
    CombineN = Table.AddColumn(Grouped, "R", each List.RemoveNulls(List.Combine(Table.ToRows([T])))),
    Row = Table.Transpose(Table.FromColumns(CombineN[R]))
in
    Row

[snasui]

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

Code: Select all

Private Sub CommandButton1_Click()
    Dim rall As Range, ra As Range
    Dim r As Range, i As Long
    Dim t As Range, k As Integer
    With Me
        If Application.Sum(.Range("a:a")) = 0 Then Exit Sub
        Set rall = .Range("a:a").SpecialCells(xlCellTypeConstants, 1)
        For i = 1 To rall.Areas.Count
            k = 4
            Set ra = rall.Areas(i)
            For Each r In ra
               Set t = rall.Areas(i).Range("a1").Offset(-1, k)
               t.Resize(1, 3).Value = r.Resize(1, 3).Value
               r.ClearContents
               k = k + 3
            Next r
        Next i
        .Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
    End With
End Sub

[JackapongT]

ขอบคุณอาจารย์ทั้งสองครับ
ลองแล้วเป็นไปตามเงื่อนไขครับ
- ของท่าน Bo_ry สามารถ Copy ข้อมูลในแต่ละ Row ได้ แต่ยังไม่ได้ใส่การ Shift Row ว่างขึ้นบรรทัดบน
- ของ อ.snasui สามารถ Copy ข้อมูลได้และ Shift Row blank ขึ้นข้างบนได้ แต่ ยังเป็นการ Copy เลข 123 ถ้ามีการเพิ่มเลขเข้ามาจะยังคง Copy ได้แค่ 123

อย่างไรก็ตามเดี๋ยวผมขอนำไปดัดแปลงต่อได้ครับ ขอขอบพระคุณทั้ง 2 ท่านครับ