[發問] 如何將Raw data 轉成表

請教VBA 如何將Raw data 轉成表 (如圖)

Transpose.jpg (132.87 KB)

Transpose.zip (7.03 KB)

樓主熱帖

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

2^#

發表於 2020-7-31 02:45 | 只看該作者

本帖最後由 n7822123 於 2020-7-31 02:50 編輯

回復 1# ABK

你的圖片[H3]欄位的值好像錯了~~~

時間晚了所以沒寫註解，有問題再發問

程式如下，試試看!

Sub test0731()
Dim Arr, S$, T$, R%, Ro%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Arr = Range([A2], [C3].End(4))
With Sheets.Add
.[A1].Resize(UBound(Arr), 3) = Arr
With .[A1].CurrentRegion
   .Sort key1:=.Item(1), order1:=xlAscending, _
            key2:=.Item(3), order1:=xlAscending
End With
Arr = .[A1].CurrentRegion: .Delete
End With
[F1].CurrentRegion.Offset(1).ClearContents
ReDim Brr(1 To 1000, 1 To 7)
For R = 1 To UBound(Arr)
  If InStr(S, "-" & Arr(R, 1) & "-") = 0 Then
Ro = Ro + 1: T = Arr(R, 1): K = 1
Brr(Ro, 1) = Arr(R, 1)
Brr(Ro, 2) = Arr(R, 2)
Brr(Ro, 5) = Arr(R, 3)
S = S & "," & "-" & Arr(R, 1) & "-"
  Else
If Arr(R, 1) = T And K < 3 Then
   Brr(Ro, 2 + K) = Arr(R, 2)
   Brr(Ro, 5 + K) = Arr(R, 3)
   K = K + 1
End If
  End If
Next R
[F2].Resize(UBound(Brr), 7) = Brr
End Sub

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

ABK

中學生 Rank: 2

帖子: 115
主題: 24
精華: 0
積分: 178
點名: 0
作業系統: WIN10
軟體版本: Office2016
閱讀權限: 20
性別: 男
註冊時間: 2011-1-12
最後登錄: 2024-11-15

3^#

發表於 2020-7-31 09:56 | 只看該作者

回復 2# n7822123

感謝阿龍大 !
OK了!

我的圖中H3的值是 DD-2 才對

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2842
主題: 10
精華: 0
積分: 2898
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-4-28

4^#

發表於 2020-8-1 10:16 | 只看該作者

Sub TEST()
Dim Arr, Brr, i&, T$, R&, C&, Mx&
[F2:L2000].ClearContents
With Range([A1], [C65536].End(xlUp))
   Brr = .Value '原資料存入brr
   .Sort Key1:=.Item(1), Order1:=xlAscending, _
         Key2:=.Item(3), Order2:=xlAscending, Header:=xlYes '排序
   Arr = .Value '排序後資料存入arr
   .Value = Brr 'brr貼回原區
End With
ReDim Brr(1 To UBound(Arr), 1 To 7)
For i = 2 To UBound(Arr)
If Arr(i, 1) <> T Then 'A欄--與上一格不相同時
   R = R + 1: C = 0: T = Arr(i, 1): Brr(R, 1) = T '行號r+1: 欄位c歸零: T重新賦值: Brr填入T
End If
C = C + 1: If C > 3 Then GoTo 101 '累計c欄位: 大于3時--略過
Brr(R, C + 1) = Arr(i, 2): Brr(R, C + 4) = Arr(i, 3) '填入[料件]:填入[料件批次]
101: Next i
[F2:L2].Resize(R) = Brr
End Sub

==========================

TOP

n7822123