返回列表 上一主題 發帖

[發問] 資料整理

[發問] 資料整理

各位大大好,

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

test2.zip (7.88 KB)

回復 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
11.PNG

TOP

隨意窩 "EXCEL迷"  blog  或https://blog.xuite.net/hcm19522/twblog
已收集8500篇 EXCEL函數

TOP

回復 2# samwang


    謝謝,測試ok

TOP

回復 3# hcm19522


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

TOP

回復 4# 蘿蔔泥


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

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

TOP

隨意窩 "EXCEL迷"  blog  或https://blog.xuite.net/hcm19522/twblog
已收集8500篇 EXCEL函數

TOP

本帖最後由 samwang 於 2021-11-4 12:03 編輯

回復 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
22.PNG

TOP

VBA附檔:
Xl0000805.rar (12.08 KB)

效果:
xx001.gif
2021-11-6 19:01

TOP

        靜思自在 : 有多少力量就做多少事,不要心存等待,等待才會落空。
返回列表 上一主題