返回列表 上一主題 發帖

[發問] 如資料行、列數不一定如何統一合併為兩攔且以空格分開

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2013-2-19 00:36 | 顯示全部帖子
回復 1# billchenfantasy
是否也要排除重複?
  1. Sub ex()
  2. Dim Rng As Range, A As Range, C As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. d("first") = Array("Mplan_no", "Mdate")
  5. [A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut
  6. [C1].Insert
  7. For Each A In Range([A2], [A2].End(xlDown))
  8. mystr = "": x = "": y = ""
  9.   Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)
  10.   For Each C In Rng
  11.      mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C)
  12.      x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))
  13.      y = IIf(y = "", C, y & " " & C)
  14.   Next
  15.   d(mystr) = Array(x, y)
  16. Next
  17. [C:D].Cut [A1].End(xlToRight).Offset(, 1)
  18. [C:D].Delete
  19. [A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
  20. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2013-2-19 11:05 | 顯示全部帖子
回復 6# billchenfantasy

若依你的範例說明是要移除重複(原22列資料，整理後為15列)
是有先將最末2欄向前移動，只是有再恢復原貌而以
  1. Sub ex()
  2. Dim Rng As Range, A As Range, C As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. d("first") = Array("Mplan_no", "Mdate")    '新標題
  5. [A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut  '最後2欄剪下
  6. [C1].Insert  '在C欄插入剪下的儲存格
  7. For Each A In Range([A2], [A2].End(xlDown))
  8. mystr = "": x = "": y = ""
  9.   Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)  '以日期作為基準
  10.   For Each C In Rng
  11.      'mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C) '若要排除重複則使用此為字典索引
  12.      x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))
  13.      y = IIf(y = "", C, y & " " & C)
  14.   Next
  15.   s = s + 1
  16.   d(s) = Array(x, y)
  17.   'd(mystr) = Array(x, y)  '若要排除重複則使用此為字典索引
  18. Next
  19. [C:D].Cut [A1].End(xlToRight).Offset(, 1)  '將C:D欄剪下貼回資料表最末端
  20. [C:D].Delete  'C:D剪下後變成空白欄，所以將其刪除，回覆成原資料表
  21. [A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
  22. End Sub   
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2013-2-19 15:36 | 顯示全部帖子
回復 8# billchenfantasy
不知是否可以再請教若將"重複的資料刪除"這項改為將無0-0的那一列刪除   
你說本例中是人工比對刪除不含0-0的列
但是，原資料A欄都是0-0，為何是刪除不含0-0?
若排除不含0-0的列，就在加入字典時判斷是否含有0-0
  1. Sub ex()
  2. Dim Rng As Range, A As Range, C As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. d("first") = Array("Mplan_no", "Mdate")    '新標題
  5. [A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut  '最後2欄剪下
  6. [C1].Insert  '在C欄插入剪下的儲存格
  7. For Each A In Range([A2], [A2].End(xlDown))
  8. mystr = "": x = "": y = ""
  9.   Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)  '以日期作為基準
  10.   For Each C In Rng
  11.      'mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C) '若要排除重複則使用此為字典索引
  12.      x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))
  13.      y = IIf(y = "", C, y & " " & C)
  14.   Next
  15.   If InStr(x, "0-0") > 0 Then '整列中不含"0-0"
  16.   s = s + 1
  17.   d(s) = Array(x, y)
  18.   End If
  19.   
  20.   'd(mystr) = Array(x, y)  '若要排除重複則使用此為字典索引
  21. Next
  22. [C:D].Cut [A1].End(xlToRight).Offset(, 1)  '將C:D欄剪下貼回資料表最末端
  23. [C:D].Delete  'C:D剪下後變成空白欄，所以將其刪除，回覆成原資料表
  24. [A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
  25. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2013-3-7 14:58 | 顯示全部帖子
回復 11# billchenfantasy
是這個意思嗎?
  1. Sub ex()
  2. Dim Ar()
  3. r = 2
  4. Do Until Application.CountA(Range(Cells(r, 4), Cells(r, Columns.Count))) = 0
  5.    Set a = Cells(r, "D")
  6.    Set rng = Range(a, Cells(r, Columns.Count)).SpecialCells(xlCellTypeConstants)
  7.    For Each c In rng
  8.    ReDim Preserve Ar(s)
  9.    Ar(s) = Format(c, "yyyy/m/d")
  10.    s = s + 1
  11.    Next
  12.    a.Offset(, -1) = Join(Ar, " ")
  13.    Erase Ar: s = 0
  14.    r = r + 1
  15. Loop
  16. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2013-3-7 21:39 | 顯示全部帖子
回復 13# billchenfantasy

新問題的A、B欄資料是第一個問題整理結果，但是E蘭以後的資料應該是另外輸入
所以應該是分成兩個程序執行才對吧
至於要保持民國年格式
  1. Sub ex()
  2. Dim Ar()
  3. r = 2
  4. Do Until Application.CountA(Range(Cells(r, 4), Cells(r, Columns.Count))) = 0
  5.    Set a = Cells(r, "D")
  6.    Set Rng = Range(a, Cells(r, Columns.Count)).SpecialCells(xlCellTypeConstants)
  7.    For Each c In Rng
  8.    ReDim Preserve Ar(s)
  9.    Ar(s) = Format(c, "e/m/d")
  10.    s = s + 1
  11.    Next
  12.    a.Offset(, -1) = Join(Ar, " ")
  13.    Erase Ar: s = 0
  14.    r = r + 1
  15. Loop
  16. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 不要隨心所欲，要隨心教育自己。
返回列表 上一主題