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

ABK

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

n7822123

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

ABK

回復 2# n7822123

感謝 阿龍大 !
OK了!

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

准提部林

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



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

n7822123

回復 4# 准提部林


難得準大會上註解    

我會新增工作表再排序取值的原因是

不想動到他原本的儲存格格式~~   

ABK

回復 4# 准提部林


    感謝准堤大 !   熱心上了註解, 拜讀學習很方便 !