Board logo

標題: [發問] 如何轉置並重組資料排列方式 [打印本頁]
作者: luke    時間: 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寫出程式?

煩請先進 大大指導
[attach]11595[/attach]
作者: Hsieh    時間: 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
複製代碼
作者: luke    時間: 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程式?

煩請先進 大大指導
[attach]11610[/attach]
作者: GBKEE    時間: 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
複製代碼
作者: Hsieh    時間: 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
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)