Board logo

標題: [發問] 矩陣資料轉置的疑問 [打印本頁]
作者: fusayloveme    時間: 2015-4-1 14:24     標題: 矩陣資料轉置的疑問

各位版上的大大，想請教如何將附件中的矩陣資料，進行資料轉置成成資料庫格式呢?

嘗試過土法煉鋼的錄製後修改，但步驟繁瑣，想上來問看版上的大大是否有更好的辦法，謝謝。

資料如附件 [attach]20555[/attach]

SHEET1 為原始資料 SHEET2 希望資料生成的形式，先謝各位的幫忙。
作者: stillfish00    時間: 2015-4-1 16:35

回復 1# fusayloveme
  1. Sub test()
  2.     Dim arSrc(), arDes()
  3.    
  4.     arSrc = Sheets(1).[A1].CurrentRegion.Value
  5.     ReDim arDes(1 To 1 + (UBound(arSrc, 2) - 3) * (UBound(arSrc) - 1), 1 To 5)
  6.     '欄位名稱
  7.     arDes(1, 1) = "日期": arDes(1, 2) = "測項"
  8.     arDes(1, 3) = "測站": arDes(1, 4) = "時間"
  9.     arDes(1, 5) = "測值"
  10.         
  11.     Dim i As Long, j As Long, r As Long
  12.     r = 2
  13.     For i = 2 To UBound(arSrc)
  14.         For j = 4 To UBound(arSrc, 2)
  15.             arDes(r, 1) = arSrc(i, 1)
  16.             arDes(r, 2) = arSrc(i, 3)
  17.             arDes(r, 3) = arSrc(i, 2)
  18.             arDes(r, 4) = arSrc(1, j)
  19.             arDes(r, 5) = arSrc(i, j)
  20.             r = r + 1
  21.         Next
  22.     Next
  23.    
  24.     With Sheets.Add
  25.         With .[A1].Resize(UBound(arDes), UBound(arDes, 2))
  26.             .Value = arDes
  27.             .Borders.LineStyle = xlContinuous
  28.             .Borders.Weight = xlThin
  29.         End With
  30.     End With
  31.    
  32. End Sub
複製代碼
作者: GBKEE    時間: 2015-4-1 17:15

回復 1# fusayloveme
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, Ar(), i As Integer
  4.     With Sheets("2013")
  5.         Set Rng = .Range("A1:C1").Resize(.[A1].End(xlDown).Row)  'End(xlDown) '項目可延伸
  6.         Ar = .Range("D1").Resize(Rng.Rows.Count, .[D1].End(xlToRight).Column - 3).Value '監測值
  7.     End With
  8.     With Sheets("處理後資料")
  9.         .UsedRange.Clear
  10.         .[A1:E1] = Array("日期", "測項", "測站", "時間", "測值")
  11.         For i = 2 To Rng.Rows.Count         '從2列開始
  12.            With .Cells(.Rows.Count, "A").End(xlUp)
  13.                 .Offset(1).Resize(UBound(Ar, 2)) = Rng.Cells(i, "A").Text    '日期
  14.                 .Offset(1, 1).Resize(UBound(Ar, 2)) = Rng.Cells(i, "B")      '測項
  15.                 .Offset(1, 2).Resize(UBound(Ar, 2)) = Rng.Cells(i, "C")      '測站
  16.                 '陣列導入儲存格的值為2維陣列,元素下限索引從1開始.
  17.                 .Offset(1, 3).Resize(UBound(Ar, 2)) = Application.Transpose(Application.Index(Ar, 1))      '時間
  18.                 .Offset(1, 4).Resize(UBound(Ar, 2)) = Application.Transpose(Application.Index(Ar, 2))      '測值
  19.            End With
  20.         Next
  21.         With .UsedRange.Borders   '框線
  22.             .LineStyle = 1
  23.             .Weight = xlThin
  24.         End With
  25.     End With
  26. End Sub
複製代碼
作者: lpk187    時間: 2015-4-1 17:44

回復 1# fusayloveme

大家答案出好快，我也練習了一下
  1. Public Sub se()
  2. end1 = 2
  3. 時間 = [d1:aa1]
  4. For Each rn In Range("A2:A" & Cells(Rows.Count, "a").End(xlUp).Row)
  5.     測站 = Cells(rn.Row, "B")
  6.     測項 = Cells(rn.Row, "C")
  7.     arr = Range(Cells(rn.Row, "D"), Cells(rn.Row, "AA"))
  8.     Sheets("處理後資料").Range("A" & end1).Resize(UBound(arr, 2)) = rn
  9.     Sheets("處理後資料").Range("B" & end1).Resize(UBound(arr, 2)) = 測項
  10.     Sheets("處理後資料").Range("C" & end1).Resize(UBound(arr, 2)) = 測站
  11.     Sheets("處理後資料").Range("D" & end1).Resize(UBound(arr, 2)) = Application.Transpose(時間)
  12.     Sheets("處理後資料").Range("E" & end1).Resize(UBound(arr, 2)) = Application.Transpose(arr)
  13.     end1 = UBound(arr, 2) + end1
  14. Next
  15. With Sheets("處理後資料").[A2].Resize(end1 - 2, 5)
  16.     .Borders.LineStyle = xlContinuous
  17.     .Borders.Weight = xlThin
  18. End With
  19. End Sub
複製代碼
作者: fusayloveme    時間: 2015-4-2 15:23

回復 2# stillfish00

回復 3# GBKEE

回復 4# lpk187

感謝S大、G大及L大的幫忙，目前嘗試都可以用喔~

S大的    arDes(1, 1) = "日期": arDes(1, 2) = "測項"
    arDes(1, 3) = "測站": arDes(1, 4) = "時間"
    arDes(1, 5) = "測值"
跟
G大的 [A1:E1] = Array("日期", "測項", "測站", "時間", "測值")

讓我學到了不一樣的思考邏輯，感謝你們的幫忙~ ^^~
作者: fusayloveme    時間: 2015-4-9 15:01

回復 3# GBKEE

G大不好意思，想跟您請教一下。

因一開始是用兩個列的資料供嘗試，但實際操作上大約每次會有6993列的資料量

因此經過矩陣後，約有6993*24=167832列的資料量

但使用巨集後，僅能夠產出65521列的資料，如附件檔案(工作表11)

想請問這是EXCEL的限制? 還是有其他方式? 先謝謝您的協助。

附件檔案(GOOGLE 雲端)
作者: GBKEE    時間: 2015-4-10 14:37

本帖最後由 GBKEE 於 2015-4-10 14:40 編輯

回復 6# fusayloveme
附檔可置於壓縮檔上傳

僅能夠產出65521列的資料,你的檔案版本可能是2003.
2003的最大列數為65536,超出的列數會產生錯誤.
作者: Scott090    時間: 2015-4-17 07:56

回復 6# fusayloveme

Application.Transpose() 這種工作表函數能處理的範圍是 65536
給參考



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