12
返回列表 上一主題 發帖

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

billchenfantasy

帖子
25 
主題
4 
精華
0 
積分
50 
點名
0  
作業系統
windows 2007 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2013-1-22 
最後登錄
2014-4-29 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-2-18 14:16 | 只看該作者

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

資料說明.rar (10.54 KB)
呈上 因資料筆數較多 請各位前輩賜教 感恩
收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 2013-2-18 23:42 | 只看該作者
呈上 因資料筆數較多 請各位前輩賜教 感恩
billchenfantasy 發表於 2013-2-18 14:16


觀看你舉例的結果與上方原稿內容似乎有部分地方無法對應,例如 :
M12 雖然有對應 2002/9/24
但找不到 M63 (0-0 2-2) 裡的 2-2 (M64 是 1974/8/22 2002/9/24)
故假設你原稿中 Plan_Dat_5 與 Plan_Dat_6 (即 L 欄與 M 欄間)中間有一欄被誤刪了.
底下的程式是以此假設為基礎做出來的.
  1. Sub ex()
  2.   Dim iCols%, iCol%
  3.   Dim lRows As Long, lRow As Long
  4.   
  5.   iCols = Cells(1, Columns.Count).End(xlToLeft).Column
  6.   Range(Columns(iCols - 1), Columns(iCols)).Cut
  7.   Columns(3).Insert xlShiftToRight
  8.   lRows = Cells(Rows.Count, 1).End(xlUp).Row
  9.   
  10.   For lRow = 2 To lRows
  11.     For iCol = 3 To iCols Step 2
  12.       If Cells(lRow, iCol) <> "" Then
  13.         Cells(lRow, 1) = Cells(lRow, 1) & " " & Cells(lRow, iCol)
  14.         Cells(lRow, iCol) = ""
  15.         Cells(lRow, 2) = Cells(lRow, 2) & " " & Cells(lRow, iCol + 1)
  16.         Cells(lRow, iCol + 1) = ""
  17.       End If
  18.     Next iCol
  19.   Next lRow
  20.   End Sub
複製代碼

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 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

billchenfantasy

帖子
25 
主題
4 
精華
0 
積分
50 
點名
0  
作業系統
windows 2007 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2013-1-22 
最後登錄
2014-4-29 
4#
發表於 2013-2-19 10:21 | 只看該作者
回復 2# luhpro [/b
謝謝您的答覆與指導，確實會因計算導致誤刪的狀況發生，感謝您的細心。
您的公式在使用過後，補齊2-2那一欄的狀況下可以將資料整理至欲達成的格式。

然而在沒有補齊的狀況下，則會發生以下狀況

您的公式我會好好學習，再次感謝

TOP

billchenfantasy

帖子
25 
主題
4 
精華
0 
積分
50 
點名
0  
作業系統
windows 2007 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2013-1-22 
最後登錄
2014-4-29 
5#
發表於 2013-2-19 10:44 | 只看該作者
回復 3# Hsieh
感謝您的答覆與協助，原來有這麼多寫法可以參考
而在嘗試運用您的公式時，發現並未先將最後兩攔剪下移至0-2之前
是否是須將後三行的指令順序移動呢?
感恩

TOP

billchenfantasy

帖子
25 
主題
4 
精華
0 
積分
50 
點名
0  
作業系統
windows 2007 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2013-1-22 
最後登錄
2014-4-29 
6#
發表於 2013-2-19 10:47 | 只看該作者
回復 5# billchenfantasy

補充一點_資料是不需移除重複的謝謝您

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 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

billchenfantasy

帖子
25 
主題
4 
精華
0 
積分
50 
點名
0  
作業系統
windows 2007 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2013-1-22 
最後登錄
2014-4-29 
8#
發表於 2013-2-19 11:46 | 只看該作者
回復 7# Hsieh
謝謝您的詳細答覆@@原來如此
在範例中的結果是將無0-0的行與完成整理後的資料經人為比對後刪除的結果
由於每次取得之資料整理後均必需經過人為的比對再行刪除一些資料(列)
有時會有某些列資料重複的特例發生
故才會不需自程式中先行刪除
在範例中沒有詳細說明在此說聲抱歉，也感謝您的細心
不知是否可以再請教若將"重複的資料刪除"這項改為將無0-0的那一列刪除
中間的程式碼可以如何更改ㄋ 謝謝

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 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

billchenfantasy

帖子
25 
主題
4 
精華
0 
積分
50 
點名
0  
作業系統
windows 2007 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2013-1-22 
最後登錄
2014-4-29 
10#
發表於 2013-2-19 16:15 | 只看該作者
回復 9# Hsieh


    謝謝您的指導我會將您的程式寫法和手邊其他資料統整一下，加入字典判斷的準則。好好研究一番，感謝您

TOP

        靜思自在 : 屋寬不如心寬。
12
返回列表 上一主題