code แทรกคอลัมภ์ตามเงื่อนไข

[pk_da]

เรียน ผู้รู้ทุกท่าน

ดิฉันต้องการแทรกคอลัมภ์ 2 คอลัมภ์ในตารางตามไฟล์แนบ ซึ่งมีีรายละเอียดดังนี้
-ชีท data_original คือข้อมูลเดิมที่มีวันที่ติดกันเรียงต่อกันไปเรื่อย ๆ
-ชีท insert2col เป็นผลลัพธ์ที่ต้องการ คือในคอลัมภ์วันที่จะมีคอลัมภ์ที่ติดกันอยู่ ก่อนวันที่ถัดไป ซึ่งเราต้องการเพิ่ม 2 คอลัมภ์แทรกระหว่างข้อมูลแต่ละวัน ตามสีเหลืองที่ใส่ไว้ในไฟล์แนบค่ะ ซึ่งให้แทรกไปเรื่อย ๆ จนครบวันที่ทั้งหมดที่มีซึ่งจะมีเยอะมาก
ด้านล่างเป็นโค้ด vb ที่ record มา ดิฉันทราบว่าต้องใช้คำสั่งวนลูปในการแทรกแต่ไม่เคยทำโค้ดแบบนี้ค่ะ ปกติจะ record แล้วมาปรับแก้ตามที่จะใช้งาน ซึ่งกรณีนี้ยอมรับว่าไม่รู้จริง ๆ ค่ะ

รบกวนผู้รู้ชี้แนะด้วยค่ะ

Code: Select all

Sub insert_col()
'
' insert_col Macro
'

'
    Columns("K:L").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("O:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("S:T").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

[snasui]

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

Code: Select all

Dim rAll As Range
Dim i As Integer
Dim k As Integer
Dim a As Variant
With Sheets("data_orginal")
    Set rAll = .Range("h1:xfd1").SpecialCells(xlCellTypeConstants)
    a = Split(rAll.Address, ",")
    k = UBound(a)
    For i = k To 0 Step -1
        .Range(a(i)).Resize(1, 2).EntireColumn.Insert
    Next i
End With

[pk_da]

สอบถามค่ะ อาจารย์

Set rAll = .Range("h1:xfd1").SpecialCells(xlCellTypeConstants)
เป็นการกำหนด range ของคอลัมภ์ทั้งหมดใช่หรือไม่คะ
ลองนำมารันกับไฟล์จริง ปรากฎว่าแทรกไม่ครบค่ะ ไฟล์มีวันที่ถึงคอลัมภ์ GG
แต่มาโครเริ่มแทรกที่คอลัมภ์ CS ต้องแก้อย่างไรจึงแทรกทั้งหมดคะ
ตัวอย่างตามไฟล์แนบค่ะ โดย
1.รันมาโครชื่อ InsertColumn
2.รันมาโครชื่อ Insert2Col


ขอบคุณค่ะ

[snasui]

จากตัวอย่างข้อมูลในไฟล์ที่แนบมาปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Dim rAll As Range
Dim i As Integer
Dim k As Integer
With Sheets("Sheet1")
    Set rAll = .Range("h1:xfd1").SpecialCells(xlCellTypeConstants)
    For i = rAll.Count To 1 Step -1
        Debug.Print rAll(i).Address
        rAll(i).Resize(1, 2).EntireColumn.Insert
    Next i
End With

[pk_da]

ต้องรันจากชีทที่ 2 ค่ะอาจารย์ ชีทแรกเป็นข้อมูลต้นฉบับ รบกวนอีกครั้งนะคะ
ขอบคุณค่ะ
PK.

[snasui]

ลองปรับมาเองก่อน ติดแล้วค่อยถามกันต่อครับ

[pk_da]

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

Code: Select all

Sub add_2_col()
Dim rAll As Range
Dim i As Integer
Dim k As Integer
Dim a As Variant
With Sheets(2)
    Set rAll = .Range("h1:xfd1").SpecialCells(xlCellTypeConstants)
    For i = rAll.Count To 1 Step -1
    a = Split(rAll.Address, ",")
        rAll(i).Resize(1, 2).EntireColumn.Insert
    Next i
End With
End Sub

[snasui]

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

Code: Select all

Dim rAll As Range
Dim i As Integer
Dim k As Integer
With Sheets("Sheet2")
    Set rAll = .Range("h1", .Range("xfd1").End(xlToLeft))
    i = rAll.Count
    For k = i To 1 Step -1
        If rAll(k).Value <> "" Then
            rAll(k).Resize(1, 2).EntireColumn.Insert
        End If
    Next k
End With