返回列表 上一主題 發帖

[發問] 關於相對位置的複製貼上問題

[發問] 關於相對位置的複製貼上問題

我的資料長的大概像這樣
code             t0        T        cp        K        prem空一行        code             t0        T        cp        K          prem        空一行再接別的資料
ln0000001        1        1        1        4        0.865                ln0000002        1        1        1        4.25           0.6575       
ln0000162        1        1        2        4        0.0411                ln0000166        1        1        2        4.25           0.0836       
ln0008058        2        1        1        4        0.9496                ln0008059        2        1        1        4.25           0.7296       
ln0008219        2        1        2        4        0.0277                ln0008223        2        1        2        4.25           0.0577       
空兩列
code             t0        T        cp        K        prem                code             t0        T        cp        K           prem       
ln0008058        2        1        1        4        0.9496                ln0008059        2        1        1        4.25   0.7296       
ln0008219        2        1        2        4        0.0277                ln0008223        2        1        2        4.25           0.0577       
ln0016117        3        1        1        4        0.7622                ln0016118        3        1        1        4.25           0.5564       
ln0016278        3        1        2        4        0.0373                ln0016282        3        1        2        4.25           0.0815       
.空兩列再接別的資料

data set.png
2016-5-29 00:10

我希望能複製標示黃色的資料(當然原始資料本身是沒有標示黃色的)
然後貼上右邊同一列標示藍色的部位上(取代原先的值)
請問不知道能不能寫成vba 程式碼?或其他更快的方式?
aa.zip (335.14 KB)

本帖最後由 ML089 於 2016-5-29 07:16 編輯

Sub ex()
    Dim xR As Range, x%
    For Each xR In Range("A1:A108") '範圍自行修改
        If xR = "code" Then
            For x = 8 To Range("AUW1").Column Step 7 '最後複製位置自行修改
                xR(2, x).Resize(1, 6) = xR(2, 1).Resize(1, 6).Value 'code字下第2列
                xR(5, x).Resize(1, 6) = xR(5, 1).Resize(1, 6).Value 'code字下第5列
            Next
        End If
    Next
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

本帖最後由 ML089 於 2016-5-29 07:57 編輯

'自動偵測表格範圍作為處理
'限用於小表格範圍為 7*7
Sub ex()
    Dim xR As Range, x%, y%
    For y = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 7
        If Cells(y, 1) = "code" Then
            Set xR = Cells(y, 1)
            For x = 8 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7
                xR(2, x).Resize(1, 6) = xR(2, 1).Resize(1, 6).Value
                xR(5, x).Resize(1, 6) = xR(5, 1).Resize(1, 6).Value
            Next
        End If
    Next
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

回復 3# ML089

謝謝!!
這真的讓我的資料整理更有效率了!!

TOP

        靜思自在 : 對父母要知恩,感恩、報恩。
返回列表 上一主題