[發問] 陣列資料依欄位抬頭名稱進行擺放

art00083303

需求如下圖所示：

下載 (131.72 KB)

2016-4-15 21:02

列數不變，欄位會有增減

完成的紅色表格中，欄位抬頭排序不限。
我目前作法：

1.跑回圈方式抓取各日期下的資料，判斷欄位數量NN，將數據丟進列Arrdata(4-1,NN)中
2.將Arrdata()依欄位順序丟入紅色表格，這個步驟我想破頭不知道該如何達成，初步思緒：
  a.因陣列資料Arrdata(0,NN)包含欄位抬頭名稱，不曉得是否能夠判斷Arrdata()內依欄位抬頭名稱放入資料，若缺欄位就新增欄。
b.或是我的思緒是不可行的，有請大大指導。

luhpro

回復 1# art00083303

下載 (26.98 KB)

2016-4-16 04:11

1. Sub NN()
   
2.   Dim iI%, iJ%, iCol%
   
3.   Dim lRow&
   
4.   Dim aR()
   
5.   Dim vD
   
6.   
   
7.   [B22:I100].Clear ' 清掉上一次的資料
   
8.   
   
9.   Set vD = CreateObject("Scripting.Dictionary")
   
10.   iCol = 4
    
11.   While Cells(21, iCol) <> ""
    
12.     vD(CStr(Cells(21, iCol))) = iCol ' vD(項目名稱) = 欄位號碼
    
13.     iCol = iCol + 1
    
14.   Wend
    
15.   
    
16.   lRow = 22
    
17.   For iI = 2 To 14 Step 6 ' 3 個表格
    
18.     For iJ = 1 To 3
    
19.       With Cells(lRow, 2)
    
20.         .NumberFormat = "yyyy/m/d"
    
21.         .Value = Cells(iI + iJ, 2) ' DATE
    
22.       End With
    
23.       
    
24.       With Cells(lRow, 3)
    
25.         .NumberFormat = "hh:mm"
    
26.         .Value = Cells(iI + iJ, 3) ' TIME
    
27.       End With
    
28.       
    
29.       iCol = 4
    
30.       While Cells(iI + iJ, iCol) <> "" ' HTM 與 其他
    
31.          With Cells(lRow, vD(CStr(Cells(iI, iCol))))
    
32.            .Value = Cells(iI + iJ, iCol)
    
33.            .Interior.ColorIndex = Cells(iI + iJ, iCol).Interior.ColorIndex ' 設定底色
    
34.          End With
    
35.          iCol = iCol + 1
    
36.       Wend
    
37.       lRow = lRow + 1
    
38.     Next
    
39.   Next
    
40. End Sub

複製代碼

放.zip (7.12 KB)

陣列資料依欄位抬頭名稱進行擺放
下載次數: 3

2016-4-16 04:12

最後, 再呼籲一下,
若資料較多且無規律性,
請開串的人順便提供範例檔,
可加快大家回文的速度. (節省 Key 範例檔資料的時間)

art00083303

回復 2# luhpro
謝謝luhpro 大大
我吸收一下您提供的代碼，
您的呼籲是我思考未周到之處，一定改進~!

art00083303

回復 2# luhpro
試run了大大提供的Code,
發現您的方式是，總表欄位名稱已知，將3個表格資料分門別類完成總表。
我的問題傾向於已知欄位為3個表的欄位抬頭(扣除"日期"、"時間"欄，總表Total未必是6欄)，藉由大大提供的CODE，小弟欲改進地方卡在於：
判斷總共有幾個欄位抬頭(重複欄位算做1欄)，本例中重複性的有6欄，非重複性的有2欄，因此總表形成欄位共有6+2欄。
還請大大指教。
放.zip (18.84 KB)

下載次數: 3

2016-4-16 10:57

luhpro

回復 4# art00083303
那就在抓取資料時, 一併建立結果標題攔 : (當然, 順序會變成依抓取先後排列)

下載 (114.55 KB)

2016-4-17 23:10

1. Private Sub cbMerge_Click()
   
2.   Dim iI%, iJ%, iSCol%, iTCol%
   
3.   Dim lRow&
   
4.   Dim aR()
   
5.   Dim vD
   
6.   
   
7.   Rows("21:" & Rows.Count).Clear ' 清掉上一次的資料(含標題攔)
   
8.   
   
9.   Set vD = CreateObject("Scripting.Dictionary")
   
10.   
    
11.   Cells(21, 2) = "DATE"
    
12.   Cells(21, 3) = "TIME"
    
13.   
    
14.   lRow = 22
    
15.   iTCol = 4
    
16.   For iI = 2 To 14 Step 6 '3 個表格
    
17.     iSCol = 4
    
18.     While Cells(iI, iSCol) <> "" ' 檢查標題攔
    
19.       If Not (vD.Exists(CStr(Cells(iI, iSCol)))) Then
    
20.         vD(CStr(Cells(iI, iSCol))) = iTCol
    
21.         Cells(21, iTCol) = Cells(iI, iSCol)
    
22.         iTCol = iTCol + 1
    
23.       End If
    
24.       iSCol = iSCol + 1
    
25.     Wend
    
26.    
    
27.     For iJ = 1 To 3
    
28.       With Cells(lRow, 2)
    
29.         .NumberFormat = "yyyy/m/d"
    
30.         .Value = Cells(iI + iJ, 2) ' DATE
    
31.       End With
    
32.       
    
33.       With Cells(lRow, 3)
    
34.         .NumberFormat = "hh:mm"
    
35.         .Value = Cells(iI + iJ, 3) ' TIME
    
36.       End With
    
37.       
    
38.       iSCol = 4
    
39.       While Cells(iI + iJ, iSCol) <> ""
    
40.         With Cells(lRow, vD(CStr(Cells(iI, iSCol))))
    
41.           .Value = Cells(iI + iJ, iSCol)
    
42.           .Interior.ColorIndex = Cells(iI + iJ, iSCol).Interior.ColorIndex ' 複製底色
    
43.         End With
    
44.         iSCol = iSCol + 1
    
45.       Wend
    
46.       lRow = lRow + 1
    
47.     Next
    
48.   Next
    
49. End Sub

複製代碼

放-a.zip (11.18 KB)

下載次數: 1

2016-4-17 23:11

art00083303

回復 5# luhpro
經運行，完全符合需求~!!
謝謝大大，受教了