返回列表 上一主題 發帖

[發問] 將指定欄位內有資料的部份,搬移插入到指定列

marklos

帖子
63 
主題
15 
精華
0 
積分
100 
點名
0  
作業系統
WINXP 
軟體版本
SP3 
閱讀權限
20 
註冊時間
2011-12-22 
最後登錄
2024-8-21 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-5-12 12:24 | 只看該作者

[發問] 將指定欄位內有資料的部份,搬移插入到指定列

本帖最後由 marklos 於 2012-5-12 12:27 編輯

(Sheet1)待處理工作表


(Sheet2)處理後
將D欄位內 , 有資料的儲存格搬移到下一列C欄的位置,該列位置跨欄置中 , 並刪除D欄~


感謝~~

QQ.rar (5.65 KB)

收藏 分享

icestormer

帖子
127 
主題
28 
精華
0 
積分
160 
點名
0  
作業系統
W7 
軟體版本
2003 
閱讀權限
20 
性別
男 
註冊時間
2010-11-1 
最後登錄
2017-5-20 
2#
發表於 2012-5-12 13:13 | 只看該作者
回復 2# act09132


   這位仁兄 想要有權限也不是這樣洗版的吧?

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
3#
發表於 2012-5-12 15:08 | 只看該作者
回復 1# marklos
  1. Sub xx()
  2. For d = [a1].End(xlDown).Row To 2 Step -1
  3.   If Cells(d, 4) <> "" Then
  4.      Rows(d + 1).Insert
  5.      Cells(d, 4).Copy Cells(d + 1, 3)
  6.      For i = 1 To 10
  7.        If Cells(d + 1, i) = "" Then Range(Cells(d + 1, i), Cells(d, i)).Merge
  8.      Next i
  9.   End If
  10. Next d
  11. Columns(4).Delete
  12. End Sub
複製代碼

TOP

marklos

帖子
63 
主題
15 
精華
0 
積分
100 
點名
0  
作業系統
WINXP 
軟體版本
SP3 
閱讀權限
20 
註冊時間
2011-12-22 
最後登錄
2024-8-21 
4#
發表於 2012-5-19 22:45 | 只看該作者
回復 3# register313


    感謝您的幫忙~~謝謝!

TOP

marklos

帖子
63 
主題
15 
精華
0 
積分
100 
點名
0  
作業系統
WINXP 
軟體版本
SP3 
閱讀權限
20 
註冊時間
2011-12-22 
最後登錄
2024-8-21 
5#
發表於 2012-6-6 09:58 | 只看該作者
回復 3# register313

    感謝您上次的幫忙~ 因為需求功能有些許變更  , 還請撥控幫忙一下 ...
(Sheet1)續上次的問題 , 待處理工作表內多了E欄位 "PN2"

(Sheet2)處理後
將D欄位以及E欄內 , 有資料的儲存格依照順序插入至C欄的下一列位置, 且該列其他欄位均複製上一列的資料 , 並刪除D欄與E欄~


附件
Excel-Q5.rar (6.34 KB)

2012-06-06_093443.jpg (91.38 KB)

2012-06-06_093443.jpg

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
6#
發表於 2012-6-6 10:50 | 只看該作者
本帖最後由 register313 於 2012-6-6 13:04 編輯

回復 5# marklos
  1. Sub xx()
  2. Sheets("sheet1").Cells.Copy Sheets("sheet2").[A1]
  3. Sheets("sheet2").Select
  4. For d = [A1].End(xlDown).Row To 2 Step -1
  5.   c = Application.CountA(Cells(d, 4).Resize(1, 2))
  6.   If Cells(d, 4) <> "" Then
  7.      Rows(d).Copy
  8.      Rows(d + 1).Resize(c).Insert Shift:=xlDown
  9.      Cells(d + 1, 3).Resize(c, 1) = Application.Transpose(Cells(d, 4).Resize(1, 2))
  10.   End If
  11. Next d
  12. Columns("d:e").Delete
  13. End Sub
複製代碼
  1. Sub yy()
  2. Set d = CreateObject("scripting.dictionary")
  3. With Sheets("sheet1")
  4.   For i = 2 To .[A1].End(xlDown).Row
  5.     Ar = .Range(.Cells(i, "A"), .Cells(i, "K"))
  6.     d(.Cells(i, 3).Value) = Ar
  7.     For j = 4 To 5
  8.       If .Cells(i, j) <> "" Then
  9.         Ar(1, 3) = .Cells(i, j)
  10.         d(.Cells(i, j).Value) = Ar
  11.       End If
  12.     Next j
  13.   Next i
  14. End With
  15. With Sheets("sheet2")
  16.   .Cells = ""
  17.   Sheets("sheet1").Rows(1).Copy .[A1]
  18.   .[A2].Resize(d.Count, 11) = Application.Transpose(Application.Transpose(d.items))
  19.   .Columns("D:E").Delete
  20.   .[A1].CurrentRegion.Borders.LineStyle = xlContinuous
  21. End With
  22. End Sub
複製代碼

TOP

        靜思自在 : 人事的艱難與琢磨，就是一種考驗。
返回列表 上一主題