[發問] 資料排列問題

sandra_wang

想請教各位前輩~
(請大家幫我看看附件)
我要如何把左邊的資料依照Max數量,Min數量,Middle數量把資料從左邊排列到右邊?
排列的規則是從H欄位開始，只要H欄位不是0的就要把欄位B~E的資料填到右邊表格
H欄位數量如果是"1"，右邊表格就填入一次，數量如果是"2"，右邊表格就填入2次，依此類推...

H欄位的部份處理完，接著換I欄位的部份，
I欄位數量如果是"1"，右邊表格就填入一次，數量如果是"2"，右邊表格就填入2次，依此類推…

最後是J欄位的部份，
J欄位數量如果是"1"，右邊表格就填入一次，數量如果是"2"，右邊表格就填入2次，依此類推…

還有右邊表格的表頭也要有讓它自動跑出來Max_1, Max_2,...

拜託大家幫幫我看看要怎麼用VBA寫呢?
(我還是小學生沒辦法下載檔案，請大家多多指教!!)

kimbal

其實這個不一定要用VBA
如果MAX,MIDDLE,MIN下數字沒重覆 可以用公式得出
M3=INDIRECT("B"&MATCH(1,H:H,0))
M4=INDIRECT("C"&MATCH(1,H:H,0))
M5=INDIRECT("D"&MATCH(1,H:H,0))
M6=INDIRECT("E"&MATCH(1,H:H,0))

N3=INDIRECT("B"&MATCH(2,H:H,0))
N4=INDIRECT("C"&MATCH(2,H:H,0))
N5=INDIRECT("D"&MATCH(2,H:H,0))
N6=INDIRECT("E"&MATCH(2,H:H,0))

....

公式的方法也有很多,可以試試找找

sandra_wang

感謝版主的回答~~
但是欄位B-欄位J 的資料會一直變化，每次進來的資料都不同，所以沒辦法用INDIRECT去比對。

因為每次進來的資料欄位H-J的數量都不一定，只要不是零的時候，就要把那列的資料填到右邊表格，
而且數量是多少，那筆資料就要出現幾次，

還是希望各位前輩可以再指導我一下，謝謝大家。

oobird

你應該po你的文件，想幫你的人才幫得上手。
難道你要別人參照你的圖去建個檔案？

sandra_wang

謝謝樓上的超級版主提醒!!
已經補上了!!

Hsieh

回復 5# sandra_wang
妳的範例的middle好像應該只有一筆才對

1. Sub Ex()
   
2. Dim A As Range, d As Object, Col As Integer, s As Long, r As Long, k As Integer, Mystr As String
   
3. Dim ky As Variant
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set A = Range([M1], [M1].End(xlToRight))
   
6. A.Resize(10, A.Count) = ""
   
7. Col = 13
   
8. For k = 8 To 10
   
9. If Application.Count(Columns(k)) > 0 Then
   
10.    For Each A In Columns(k).SpecialCells(xlCellTypeConstants, 1)
    
11.       For i = 1 To A
    
12.          s = s + 1
    
13.          r = A.Row
    
14.          Mystr = Replace(Cells(1, k), "數量", "_") & s
    
15.          d(Mystr) = Application.Transpose(Cells(r, 2).Resize(, 4))
    
16.       Next
    
17.    Next
    
18.    
    
19.    For Each ky In d.keys
    
20.       Cells(1, Col) = ky
    
21.       Cells(3, Col).Resize(4, 1) = d(ky)
    
22.       Col = Col + 1
    
23. 
    
24.    Next
    
25. End If
    
26. s = 0: d.RemoveAll
    
27. Next
    
28. End Sub

複製代碼

sandra_wang

回覆#6 Hsieh 超級版主~
謝謝你提供我這個答案，因為有些我還是看不是很懂，但是我自己有調整後再試了一下!

因為我有三種產品需要這樣的排列，CPU,HDD,Memory
但是我自己改過之後，CPU的排列我可以順利跑出來，可是HDD和Memory的部份就跑不出來，
可以請樓上的超級版主幫我看看我哪裡錯了嗎?(我改過的部分有用紅色的字體標示)
我有附上檔案，請幫我看"問題part2"的附件

sandra_wang

回覆#6 Hsieh 超級版主~
可以請你幫看看"我的問題part2"，
我的CPU本來可以跑出來，現在Priority 3 & Vendor的資料又跑不出來了，會出現#N/A。
其他HDD&Memory的資料我要怎麼調整它才會跑到橘色跟淺綠藍色的位置呢?
謝謝你!!

GBKEE

回復 8# sandra_wang
每一程序是依據,每各個案所量身訂製的 .不一定套用的上.
請要說明一下差異是在哪裡, 檔案是如此龐大我找得眼花也看不出來如何幫你.
第一個問題 另有一解請參考

1. Sub Ex()
   
2.     Dim Rng(1 To 2) As Range, i%, ii%, C%, T%, E
   
3.     With Sheet1
   
4.         .Range("M1", .Range("M1").End(xlToRight)).EntireColumn.Clear
   
5.         Set Rng(1) = .Range("L3", .Range("L3").End(xlDown))
   
6.         C = 1
   
7.         For i = 8 To 10
   
8.             T = 1   '欄位數量->歸零
   
9.             For Each E In .Range(.Cells(1, i), .Cells(Rows.Count, i).End(xlUp)).SpecialCells(xlCellTypeConstants).Cells
   
10.                 If Val(E) > 0 Then
    
11.                     For ii = 1 To Val(E)
    
12.                         Set Rng(2) = Rng(1).Offset(, C)
    
13.                         .Cells(1, Rng(2).Column) = Replace(.Cells(1, i), "數量", "_" & T)
    
14.                         Rng(2).Value = Application.Transpose(.Cells(E.Row, "b").Resize(, 4))
    
15.                         Rng(2).Interior.ColorIndex = E.Interior.ColorIndex
    
16.                         C = C + 1 '往右加1欄  Rng(1).Offset(, C)
    
17.                         T = T + 1
    
18.                     Next
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.     End With
    
23. End Sub

複製代碼

Hsieh

回復 8# sandra_wang

1. Sub Ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set Rng = Range("CL2,CX2,DJ2")
   
5. [ED2:EL65536] = ""
   
6. r = 2
   
7. For Each A In Rng
   
8.    k = 135
   
9.    For i = 7 To 9
   
10.    s = 1
    
11.       If Application.Count(A.Offset(, i).EntireColumn) > 0 Then
    
12.       Cells(r, 134).Resize(5, 1) = Application.Transpose(Array(A, A.Offset(1, 1), A.Offset(1, 2), A.Offset(1, 3), A.Offset(1, 4)))
    
13.          For Each b In A.Offset(, i).EntireColumn.SpecialCells(xlCellTypeConstants, 1)
    
14.             For j = 1 To b
    
15.                Mystr = Cells(3, b.Column) & "_" & s
    
16.                s = s + 1
    
17.                d(Mystr) = Application.Transpose(Cells(b.Row, A.Column + 1).Resize(, 4))
    
18.             Next
    
19.          Next
    
20.          For Each ky In d.keys
    
21.             Cells(r, k) = ky: Cells(r + 1, k).Resize(4, 1) = d(ky)
    
22.             k = k + 1
    
23.          Next
    
24.          d.RemoveAll
    
25.       End If
    
26.       Next
    
27.       r = r + 12
    
28. Next
    
29. End Sub

複製代碼