返回列表 上一主題 發帖

[發問] 如何轉置並重組資料排列方式

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-7-6 00:35 | 只看該作者

[發問] 如何轉置並重組資料排列方式

各位大大

A:C欄為區塊資料, 每個區塊有3或5資料列(中間以空白列隔開).

將區塊資料轉置至E:I欄並對各區塊進行重組方式如下:
1.C欄儲存格要由中文字後面算, 取全部的英文字和其他字元.
    如:C2儲存格 "站牌接駁運送組99LA68XY美而美"
          要取 "99LA68XY美而美" (紅字所示)
          C3儲存格 "等候停車亭CC1-B18Z1"
          要取 "CC1-B18Z1" (紅字所示)
     餘此類推.....

2.完成第1點後進行資料全面轉置作業, 若該區塊資料列為3 列, 填
    入E,F和 I   欄 (如藍色弧線所示) , 若區塊資料列為5列, 同前述方
     式依序填進 E ~ I 欄

3. E ~ I 欄為完成後顯示資料.

因區塊資料列常做修改,  如何利用VBA寫出程式?

煩請先進 大大指導
TEST22.rar (48.57 KB)
收藏 分享

Hsieh

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

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-7-6 10:36 | 只看該作者
回復 1# luke
  1. Sub ex()
  2. Dim Rng As Range, r&, ar(), i%, j%, k%, n%, m$
  3. Set Rng = Range("A:C").SpecialCells(xlCellTypeConstants)
  4. r = 2
  5. For i = 1 To Rng.Areas.Count
  6.    ar = Rng.Areas(i).Value
  7.    For j = 1 To UBound(ar, 1)
  8.       k = 1
  9.       Do Until Asc(Mid(ar(j, 3), k)) >= 1 And Asc(Mid(ar(j, 3), k)) <= 256
  10.         k = k + 1
  11.       Loop
  12.       m = Mid(ar(j, 3), k)
  13.       n = Application.Match(ar(j, 1), Array("巴士", "站牌起點", "站牌中繼A", "站牌中繼B", "站牌終點"), 0)
  14.       Cells(r, n + 4).Resize(3, 1) = Application.Transpose(Array(ar(j, 1), m, ar(j, 2)))
  15.    Next
  16. r = r + 3
  17. Next
  18. End Sub
複製代碼
學海無涯_不恥下問

TOP

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
3#
發表於 2012-7-7 15:18 | 只看該作者
回復 2# Hsieh

謝謝H大

若C欄區塊資料中部分有英文字開頭如 "XY" (粉紅字所示), 說明如下:
1.C1儲存格 "XY站牌接駁運送組99LA68XY美而美"
          要取 "99LA68XY美而美" (紅字所示)
    C7儲存格 "XY等候停車亭CC1-B25 Z1"
          要取 "CC1-B25 Z1" (紅字所示)
    C14儲存格 "XY短暫休息OAK-B21"
          要取 "OAK-B21" (紅字所示)

2.進行轉置重組後. E ~ I 欄顯示資料不變的話, 應 如何修改VBA程式?

煩請先進 大大指導
TEST22A.rar (14.13 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2012-7-7 17:08 | 只看該作者
回復 3# luke
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ar(2 To 3), E As Range
  4.     With sheet1
  5.         Ar(2) = .Columns(2)                       'B欄資料 置入陣列
  6.         Ar(3) = .Columns(3)                       'C欄資料 置入陣列
  7.         .Columns(2) = Ar(3)                       'B欄資料轉成C欄資料
  8.         .Columns(3) = Ar(2)                       'C欄資料轉成B欄資料
  9.         .Columns(2).Replace "*運送組", ""         'B欄資料 消除字串 *運送組
  10.         .Columns(2).Replace "*停車亭", ""         'B欄資料 消除字串 *停車亭
  11.         .Columns(2).Replace "*休息", ""           'B欄資料 消除字串 *休息
  12.         .Range("E:I").Clear
  13.         For Each E In .Range("A:C").SpecialCells(xlCellTypeConstants).Areas
  14.         'Areas 屬性 傳回 Areas 集合，此集合代表多重範圍中的所有範圍。唯讀。
  15.            E.Copy                                                 '複製
  16.             With .Range("E" & .Rows.Count).End(xlUp).Offset(1)    'E欄由下往上
  17.                 .PasteSpecial , Transpose:=True                   '轉置
  18.                 If .Cells(1, 3) = "站牌終點" Then .Cells(1, 3).Resize(3).Cut Destination:=.Cells(1, 5)
  19.                  .Resize(3, 5).Borders.LineStyle = xlNone           '消除框線
  20.                 .Resize(3, 5).BorderAround 1                        '製定外框線
  21.             End With
  22.         Next
  23.          .Range("E:I").EntireColumn.AutoFit
  24.          .Range("E1").Select
  25.         .Columns(2) = Ar(2)                                              '還原B欄資料                       
  26.         .Columns(3) = Ar(3)                                              '還原C欄資料                       
  27.     End With
  28. End Sub
複製代碼

TOP

Hsieh

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

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2012-7-8 00:13 | 只看該作者
回復 3# luke
  1. Sub ex()
  2. Dim Rng As Range, r&, ar(), i%, j%, k%, n%, m$
  3. Set Rng = Range("A:C").SpecialCells(xlCellTypeConstants)
  4. r = 2
  5. For i = 1 To Rng.Areas.Count
  6.    ar = Rng.Areas(i).Value
  7.    For j = 1 To UBound(ar, 1)
  8.       k = 1
  9.       Do Until (Asc(Mid(ar(j, 3), k)) < 0 Or Asc(Mid(ar(j, 3), k)) > 256) And Asc(Mid(ar(j, 3), k + 1)) >= 0 And Asc(Mid(ar(j, 3), k + 1)) <= 256
  10.         k = k + 1
  11.       Loop
  12.       m = Mid(ar(j, 3), k + 1)
  13.       n = Application.Match(ar(j, 1), Array("巴士", "站牌起點", "站牌中繼A", "站牌中繼B", "站牌終點"), 0)
  14.       Cells(r, n + 4).Resize(3, 1) = Application.Transpose(Array(ar(j, 1), m, ar(j, 2)))
  15.    Next
  16. r = r + 3
  17. Next
  18. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 小事不做、大事難成。
返回列表 上一主題