[發問] 資料整理

蘿蔔泥

各位大大好，

小妹我整理資料時出現了一個難題，想請各位幫忙處理
編號跟原料可能相同但批號也許不同(資料sheet)，如何呈現出主管想看的表單(呈現表sheets)
目前公式只能抓出第一筆，無法抓到第二筆批號，有辦法可以解決嗎？
實際上編號是100-300筆
原料是A-Z，但不確定同編號+原料的料號有幾筆
舉例編號100原料C的料號目前2筆，但實際有可能4-5筆

samwang

回復 1# 蘿蔔泥

請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, xD1, TT, n%, C%, m%, i&, k%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([資料!c1], [資料!a65536].End(3))
For i = 2 To UBound(Arr)
    If Arr(i, 2) = "" Then GoTo 99
    If Not xD.Exists(Arr(i, 2) & "") Then
        k = k + 1: xD(Arr(i, 2) & "") = k
    End If
99: Next
ReDim Brr(1 To UBound(Arr), 1 To xD.Count + 1)
With Sheets("呈現表")
    .Range("b1").Resize(, xD.Count) = xD.keys
    For i = 2 To UBound(Arr)
        C = xD(Arr(i, 2) & "") + 1
        If xD1.Exists(Arr(i, 1)) Then
            m = xD1(Arr(i, 1))
            If IsEmpty(Brr(m, C)) Then Brr(m, C) = Arr(i, 3) Else Brr(m, C) = Brr(m, C) & "," & Arr(i, 3)
        Else
            n = n + 1: xD1(Arr(i, 1)) = n
            Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
        End If
    Next
    .Range("a2").Resize(n, xD.Count) = Brr
End With
End Sub

hcm19522

https://blog.xuite.net/hcm19522/twblog/590100752

蘿蔔泥

回復 2# samwang


    謝謝，測試ok

蘿蔔泥

回復 3# hcm19522


    謝謝，請問如果在不知道同一原料有幾筆的狀態下是不是這函數就無法使用？

samwang

回復 4# 蘿蔔泥


不好意思，2#有個小問題，由xD.Count改為Ubound(Brr,2)，如下紅字部分，謝謝

.Range("a8").Resize(n, UBound(Brr, 2)) = Brr

hcm19522

回復 5# 蘿蔔泥

https://blog.xuite.net/hcm19522/twblog/590104998

samwang

回復 1# 蘿蔔泥

請測試看看，謝謝。

Sub 單筆資料()
Dim Arr, Brr, Crr(1 To 1, 1 To 100), xD, xD1, m%, m0%, m1%
Dim k0%, k1%, k%, ky, CMax, T$, n%, C%, C1%, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheets("資料")
        With .Range(.[C1], .[a65536].End(xlUp))
            Brr = .Value
            .Sort Key1:=.Item(1), Order1:=xlAscending, _
                Key2:=.Item(2), Order2:=xlAscending, Header:=xlYes
            Arr = .Value
            .Value = Brr
        End With
End With
For i = 2 To UBound(Arr)
    If Arr(i, 2) = "" Then GoTo 97
    T = Arr(i, 1) & "_" & Arr(i, 2)
    If Not xD.Exists(T) Then '取欄數
        xD(Arr(i, 2) & "") = 1: xD(T) = ""
    Else
        k0 = xD(Arr(i, 2) & ""): k1 = xD1(Arr(i, 2) & "")
        If k0 > k1 Then k = k0 + 1 Else k = k1 + 1
        xD1(Arr(i, 2) & "") = k
    End If
97: Next
For Each ky In xD.keys    '列出第一列表頭
    If InStr(ky, "_") Then GoTo 98
    If xD1.Exists(ky) Then
        For j = 1 To xD1(ky): y = y + 1: Crr(1, y) = ky: Next
    Else
        y = y + 1: Crr(1, y) = ky: s = s + 1
    End If
98: Next
xD1.RemoveAll
ReDim Brr(1 To UBound(Arr), 1 To y + 1)
With Sheets("呈現表")
    .[a1:aa100] = ""
    .Range("b1").Resize(, y) = Crr
    For i = 2 To UBound(Arr)
        If Arr(i, 2) = "" Then GoTo 99
        C = Application.WorksheetFunction.Match(Arr(i, 2), Sheets(2).Range("a1").Resize(, y + 1), 0)
        If xD1.Exists(Arr(i, 1)) Then
            m = xD1(Arr(i, 1))
            If IsEmpty(Brr(m, C)) Then
                Brr(m, C) = Arr(i, 3)
            Else
                If m0 = 0 Then m0 = m
                If m0 <> m Then C1 = 0
                If C1 > C Then C1 = C1 + 1 Else C1 = C + 1
                Brr(m, C1) = Arr(i, 3)
            End If
        Else
            n = n + 1: xD1(Arr(i, 1)) = n
            Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
        End If
99: Next
    .Range("a2").Resize(n, y + 1) = Brr
End With
End Sub

准提部林

VBA附檔:
Xl0000805.rar (12.08 KB)

下載次數: 8

2021-11-6 19:00

效果:

下載 (8.23 KB)

2021-11-6 19:01

Andy2483

回復 9# 准提部林
'謝謝前輩
'這帖習得多樣知識
'1.Range([資料!c1], [資料!a1].Cells(Rows.Count, 1).End(xlUp))
'  看似簡單的儲存格範圍!學到了 [資料!c1] 會讓Range()指向 資料表
'  以前誤以為 沒有工作表指向的Range() 一定是在ActiveSheet
'  否則一定要指向哪個表 Sheets("資料").Range()
'2.前輩很有心都會用不同的語法啟發後學們!不是機械式的回答!謝謝!
'3.Format(T(3), "0000") 學習到如何數字補足前方的0 成為想要的數字碼數
'4.用字典與陣列 鋪陳標題列與標題欄 好像已經看懂! 但又不會用!再勤練看看!
'5.學到 欄排序
'6.學到 去除 "|"符號(含)右邊的字元  Replace "|*", "", Lookat:=xlPart
'7.學到 留下[A1]儲存格!其餘儲存格刪除
'8.斜線隨儲存格縮放

一開始貼入:

下載 (30.28 KB)

2022-10-27 14:32

欄排序:

下載 (30.46 KB)

2022-10-27 14:32

列排序:

下載 (30.2 KB)

2022-10-27 14:33

標題列留原料與顯示格線:

下載 (32.25 KB)

2022-10-27 14:33

斜線隨儲存格縮放:

下載 (113.62 KB)

2022-10-27 14:44

以下心得註解請前輩再指教!謝謝前輩
Sub TEST_A1()
Dim Arr, Brr, xD, T$(3), i&, j%, R&, C%, X&, Y%
'↑宣告變數,批次宣告T是字串變數 T(0)~T(3)
Call 清除
'↑執行副程式 清除()

Set xD = CreateObject("Scripting.Dictionary")
'↑令 xD是字典
Arr = Range([資料!c1], [資料!a1].Cells(Rows.Count, 1).End(xlUp))
'↑令 Arr是陣列,倒入 資料表裡C1到A欄最後一個有內容儲存格
'這兩個儲存格間擴展到最小方正區域儲存格的值
ReDim Brr(1 To UBound(Arr), 1 To 200)
'↑宣告 Brr陣列的範圍! 縱向是1 到 Arr陣列的列數
'橫向是1 到 200 欄數
For i = 2 To UBound(Arr)
'↑設外順迴圈 從2 到 Arr陣列最後列數
    For j = 1 To 3
    '↑設內順迴圈 從1 到3
        T(j) = Arr(i, j)
        '↑令迴圈中 T字串變數裝入Arr陣列對應值
        If T(j) = "" Then
        '↑如果 此內迴圈中 T字串變數 裝入了空格
           GoTo 101
           '↑條件成立!就跳到 101 繼續執行
        End If
    Next j
    T(0) = T(2) & "|" & Format(T(3), "0000")
    '↑令第1個T字串變數是 第3個T字串變數 & "|" & 第4個T字串(4碼數字)
    X = xD(T(1))
    '↑令X數字變數是 xD字典裡以 第2個T字串 值為key的item
    '一開始是查不到 item!但是字典裡已經收納了 第2個T字串 值為key
    '因為X數字變數!查不到就是初始值0
    Y = xD(T(0))
    '↑令Y數字變數是 xD字典裡以 第1個T字串 值為key的item
    '一開始也是查不到 item!但是字典裡已經收納了 第1個T字串 值為key
    '因為Y數字變數!查不到就是初始值0
    If X = 0 Then
    '↑如果X數字變數是初始值0
       R = R + 1
       '↑條件成立!R數字變數就累加 1
       X = R + 1
       '↑條件成立!X數字變數又以R數字變數再 +1
       '因為標題欄是從往下第2個開始
       xD(T(1)) = X
       '↑令 xD字典中 第2個T字串變數(編號) 為key的item = X數字變數
       '所以開始裝入的item是 數字2
       Brr(X, 1) = T(1)
       '↑一開始是令Brr陣列第2列第1欄是 第2個T字串變數(編號)
       '↑這是標題欄
    End If
    If Y = 0 Then
    '↑如果Y數字變數是初始值0
       C = C + 1
       '↑條件成立!C數字變數就累加 1
       Y = C + 1
       '↑條件成立!Y數字變數又以C數字變數再 +1
       '因為標題列是從往右第2個開始
       xD(T(0)) = Y
       '↑令 xD字典中 (原料)& "|" &(批號) 為key的item = Y數字變數
       Brr(1, Y) = T(0)
       '↑一開始是令Brr陣列第1列第2欄是 第1個T字串變數 (原料)& "|" &(批號)
       '↑這是標題列
    End If
    Brr(X, Y) = T(3)
    '↑標題列欄所對應的 批號放入 Brr陣列中
101: Next i
Brr(1, 1) = "　　　原料　編號"
'↑令Brr陣列第1列第1欄儲存格的字串
With [呈現表!A1].Resize(R + 1, C + 1)
'↑R是不包含標題列!所以要 +1 ,C是不包含標題欄!所以要 +1
    .Value = Brr
    '↑將Brr陣列從 呈現表[A1]貼入值
    .Columns(2).Resize(, C).Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
    '↑欄以標題列排序
    .Rows(2).Resize(R).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
    '↑列以標題欄排序
    .Rows(1).Replace "|*", "", Lookat:=xlPart
    '↑把標題列去除 "|"符號(含)右邊的字元!標題列剩下 (原料)
    .Borders.LineStyle = 1
    '↑讓儲存格格線顯示 細實線
End With
End Sub

Sub 清除()
With Sheets("呈現表").UsedRange
    .Offset(1, 0).EntireRow.Delete
    .Offset(, 1).EntireColumn.Delete
    '留下[A1]儲存格!其餘儲存格刪除
End With
End Sub