返回列表 上一主題 發帖

[發問] Excel VBA sorting 後複製貼上

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
60  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-3-11 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-8-28 08:48 | 顯示全部帖子
回復 1# tommy.lin
  1. Sub ex()
  2. With Sheets("Sheet1")
  3. If Application.CountA(.[B:B]) = 0 Then Exit Sub
  4.    For Each a In .Range("B:B").SpecialCells(xlCellTypeConstants)
  5.       With Sheets("Data")
  6.       Set c = .Rows(1).Find(a, lookat:=xlWhole)
  7.       k = IIf(Sheets("result").Cells(1, .Columns.Count).End(xlToLeft) = "", 0, 1)
  8.       Range(c, c.End(xlDown)).Copy Sheets("result").Cells(1, .Columns.Count).End(xlToLeft).Offset(, k)
  9.       End With
  10.    Next
  11. End With
  12. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
60  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-3-11 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-9-3 14:11 | 顯示全部帖子
回復 4# tommy.lin
不懂的地方按F1看說明是最好的書籍   
Sub ex()
With Sheets("Sheet1")
If Application.CountA(.[B:B]) = 0 Then Exit Sub  'B欄無資料就跳出程序
   For Each a In .Range("B:B").SpecialCells(xlCellTypeConstants)  '循環每個B欄的資料
      With Sheets("Data")
      Set c = .Rows(1).Find(a, lookat:=xlWhole)  '在Sheets("Data")第一列找尋
      k = IIf(Sheets("result").Cells(1, .Columns.Count).End(xlToLeft) = "", 0, 1)  '假如要複製的目標位置在Sheets("result")的A欄，位移量為0
      Range(c, c.End(xlDown)).Copy Sheets("result").Cells(1, .Columns.Count).End(xlToLeft).Offset(, k) '複製資料
      End With
   Next
End With
End Sub
學海無涯_不恥下問

TOP

        靜思自在 : 口說好話、心想好意、身行好事。
返回列表 上一主題