[發問] 矩陣資料轉置的疑問

fusayloveme

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

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

資料如附件 監測資料.rar (9.44 KB)

謝謝
下載次數: 12

2015-4-1 14:22

SHEET1 為原始資料 SHEET2 希望資料生成的形式，先謝各位的幫忙。

stillfish00

回復 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

回復 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

回復 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

回復 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

回復 3# GBKEE

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

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

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

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

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

附件檔案(GOOGLE 雲端)

GBKEE

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

僅能夠產出65521列的資料,你的檔案版本可能是2003.
2003的最大列數為65536,超出的列數會產生錯誤.

Scott090

回復 6# fusayloveme

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