返回列表 上一主題 發帖

[發問] 讀取及歸類資料

回復 9# 198188

先給"送貨單"//
程式碼沒什特別~~
Xl0000113-送貨單.rar (157.61 KB)

TOP

回復 9# 198188

排架表..迴圈多層, 自行研究//
Xl0000114-排架表.rar (83.4 KB)

TOP

回復 11# 准提部林

因爲繁簡體問題,導致亂碼,導致無法運行。 因爲沒有原文,我無法修正亂碼部分。可否發一下原文給我修正。
Sub 戈()
Dim Arr, Xrr, Yrr, i&, j%, V, T$, T1$, TR, x&, y&
Call 睲埃戈
Arr = Range([L1], [A65536].End(xlUp).MergeArea)
ReDim Xrr(1 To UBound(Arr), 1 To 7)
ReDim Yrr(1 To UBound(Arr), 1 To 4)
For i = 15 To UBound(Arr)
    T = Arr(i, 1): V = Val(Arr(i, 10))
    If T Like "*L *W *H *" Then
       TR = Split(T, Chr(10)): T1 = Trim(TR(0))
       x = x + 1
       Xrr(x, 1) = T  'A 逆Τデ计沮
       Xrr(x, 2) = T1 '砯琜腹
       Xrr(x, 3) = Arr(i, 2) 'N.W.(瞓)
       Xrr(x, 4) = Arr(i, 3) 'G.W.(メ)
       Xrr(x, 5) = Val(Mid(TR(3), 2)) 'W
       Xrr(x, 6) = Val(Mid(TR(2), 2)) 'L
       Xrr(x, 7) = Val(Mid(TR(4), 2)) 'H
    End If
    '----------------------------------
    If T1 <> "" And Arr(i, 6) <> "" And V <> 0 Then
       y = y + 1
       Yrr(y, 1) = T1 '砯琜腹
       Yrr(y, 2) = Arr(i, 7) '竚
       Yrr(y, 3) = Arr(i, 6) 'ォ甧
       Yrr(y, 4) = V '计秖
    End If
i01: Next i
If x = 0 Then Exit Sub
With [N3].Resize(x, 7)
     .Value = Xrr
     .Borders.LineStyle = 1
     .WrapText = False
End With
With [v3].Resize(y, 4)
     .Value = Yrr
     .Borders.LineStyle = 1
End With
End Sub

Sub 睲埃?)
Range([T3], [N65536].End(xlUp)(3)).Delete Shift:=xlUp
Range([Y3], [V65536].End(xlUp)(3)).Delete Shift:=xlUp
End Sub

TOP

回復 12# 准提部林
因爲繁簡體問題,導致亂碼,導致無法運行。 因爲沒有原文,我無法修正亂碼部分。可否發一下原文給我修正。

Sub ╊ク()
Attribute ╊ク.VB_Description = "矗场狶  2024/1/1 魁籹リ栋"
Attribute ╊ク.VB_ProcData.VB_Invoke_Func = " \n14"
Dim Arr, Brr, Drr, Xrr, Yrr, xD, xS As Worksheet, vS As Worksheet, R&, S$, T$, i&, j&, k%, x&, y%, N&
Call 埃
Set xD = CreateObject("Scripting.Dictionary")
Set vS = Sheets("逼琜"): Xrr = vS.[a8:f8]
Arr = Range(vS.[b1], vS.[d65536].End(xlUp))
For i = 9 To UBound(Arr)
    T = Arr(i, 2)
    If T Like "SR####" Then xD(T) = vS.Cells(i, 2).MergeArea.Resize(, 5).Value
Next i
'-----------------------------
Set xS = Sheets("BF")
Arr = Range(xS.[f1], xS.[a65536].End(xlUp).MergeArea)
For i = 2 To UBound(Arr)
    If Arr(i, 1) Like "BF祘[#]###*" Then
       S = Mid(Arr(i, 1), 5, 4): N = 0
       Brr = xS.Cells(i, 1).MergeArea.Resize(, 5).Value
       ReDim Yrr(1 To 2000, 1 To 6)
       N = N + 1
       For y = 1 To 6: Yrr(N, y) = Xrr(1, Mid(123645, y, 1)): Next
       For j = 1 To UBound(Brr)
           For k = 2 To UBound(Brr, 2)
               If Brr(j, k) Like "*琜*SR####*" Then
                  T = Mid(Brr(j, k), 4, 6)
                  Drr = xD(T)
                  If IsArray(Drr) Then
                     For x = 1 To UBound(Drr)
                         N = N + 1
                         Yrr(N, 1) = "=row()-1"
                         Yrr(N, 2) = Drr(1, 1)
                         Yrr(N, 3) = Drr(1, 2)
                         Yrr(N, 4) = Drr(1, 5)
                         Yrr(N, 5) = Drr(1, 3)
                         Yrr(N, 6) = Drr(1, 4)
                     Next x
                  End If
               End If
           Next k
       Next j
       '-----------------------------------
       If N <= 1 Then GoTo i01
       Set vS = Sheets.Add(after:=vS): vS.Name = S
       With vS.[a1].Resize(N, 6)
            .Value = Yrr
            .Borders.LineStyle = 1
            .Sort Key1:=.Item(3), Order1:=xlAscending, _
                  Key2:=.Item(4), Order2:=xlAscending, _
                  Key3:=.Item(2), Order3:=xlAscending, Header:=xlYes
            T = "'" & S & "'!" & .Address
       End With
       '-----------------------------------
       ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=T).CreatePivotTable TableDestination:=vS.Range("i1"), TableName:="Pvt_1"
       vS.PivotTables("Pvt_1").AddFields RowFields:=vS.Range("C1"), ColumnFields:=vS.Range("d1")
       vS.PivotTables("Pvt_1").PivotFields(vS.Range("F1").Text).Orientation = xlDataField
    End If
    Application.CommandBars("PivotTable").Visible = False
i01: Next i
End Sub

Sub 埃()
Dim xS As Worksheet
Application.DisplayAlerts = False
For Each xS In Sheets
    If xS.Name Like "[#]###" Then xS.Delete
Next
End Sub


Sub ttt()
MsgBox Val("11 22")
End Sub
Sub Macro2()
'
' Macro2 リ栋
' 矗场狶  2024/1/1 魁籹リ栋
'

'
'   Columns("B:F").Select
  ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:="'#001'!C1:f86").CreatePivotTable TableDestination:=Range("i1"), TableName:="枷ク猂1"
    'ActiveSheet.PivotTables("枷ク猂1").SmallGrid = False
    ActiveSheet.PivotTables("枷ク猂1").AddFields RowFields:=Range("C1"), ColumnFields:=Range("d1")
    ActiveSheet.PivotTables("枷ク猂1").PivotFields(Range("F1").Text).Orientation = xlDataField
End Sub

TOP

<送貨單>

Sub 取出資料()
Dim Arr, Xrr, Yrr, i&, j%, V, T$, T1$, TR, x&, y&
Call 清除資料
Arr = Range([L1], [A65536].End(xlUp).MergeArea)
ReDim Xrr(1 To UBound(Arr), 1 To 7)
ReDim Yrr(1 To UBound(Arr), 1 To 4)
For i = 15 To UBound(Arr)
    T = Arr(i, 1): V = Val(Arr(i, 10))
    If T Like "*L *W *H *" Then
       TR = Split(T, Chr(10)): T1 = Trim(TR(0))
       x = x + 1
       Xrr(x, 1) = T  'A 欄有尺寸的數據
       Xrr(x, 2) = T1 '貨架號
       Xrr(x, 3) = Arr(i, 2) 'N.W.(淨重)
       Xrr(x, 4) = Arr(i, 3) 'G.W.(毛重)
       Xrr(x, 5) = Val(Mid(TR(3), 2)) 'W
       Xrr(x, 6) = Val(Mid(TR(2), 2)) 'L
       Xrr(x, 7) = Val(Mid(TR(4), 2)) 'H
    End If
    '----------------------------------
    If T1 <> "" And Arr(i, 6) <> "" And V <> 0 Then
       y = y + 1
       Yrr(y, 1) = T1 '貨架號
       Yrr(y, 2) = Arr(i, 7) '位置
       Yrr(y, 3) = Arr(i, 6) '內容
       Yrr(y, 4) = V '數量
    End If
i01: Next i
If x = 0 Then Exit Sub
With [N3].Resize(x, 7)
     .Value = Xrr
     .Borders.LineStyle = 1
     .WrapText = False
End With
With [v3].Resize(y, 4)
     .Value = Yrr
     .Borders.LineStyle = 1
End With
End Sub

Sub 清除資料()
Range([T3], [N65536].End(xlUp)(3)).Delete Shift:=xlUp
Range([Y3], [V65536].End(xlUp)(3)).Delete Shift:=xlUp
End Sub

TOP

<排架表>

Sub 拆分工作表()
Dim Arr, Brr, Drr, Xrr, Yrr, xD, xS As Worksheet, vS As Worksheet, R&, S$, T$, i&, j&, k%, x&, y%, N&
Call 刪除工作表
Set xD = CreateObject("Scripting.Dictionary")
Set vS = Sheets("排架表"): Xrr = vS.[a8:f8]
Arr = Range(vS.[b1], vS.[d65536].End(xlUp))
For i = 9 To UBound(Arr)
    T = Arr(i, 2)
    If T Like "SR####" Then xD(T) = vS.Cells(i, 2).MergeArea.Resize(, 5).Value
Next i
'-----------------------------
Set xS = Sheets("BF")
Arr = Range(xS.[f1], xS.[a65536].End(xlUp).MergeArea)
For i = 2 To UBound(Arr)
    If Arr(i, 1) Like "BF工程[#]###*" Then
       S = Mid(Arr(i, 1), 5, 4): N = 0
       Brr = xS.Cells(i, 1).MergeArea.Resize(, 5).Value
       ReDim Yrr(1 To 2000, 1 To 6)
       N = N + 1
       For y = 1 To 6: Yrr(N, y) = Xrr(1, Mid(123645, y, 1)): Next
       For j = 1 To UBound(Brr)
           For k = 2 To UBound(Brr, 2)
               If Brr(j, k) Like "*架*SR####*" Then
                  T = Mid(Brr(j, k), 4, 6)
                  Drr = xD(T)
                  If IsArray(Drr) Then
                     For x = 1 To UBound(Drr)
                         N = N + 1
                         Yrr(N, 1) = "=row()-1"
                         Yrr(N, 2) = Drr(1, 1)
                         Yrr(N, 3) = Drr(1, 2)
                         Yrr(N, 4) = Drr(1, 5)
                         Yrr(N, 5) = Drr(1, 3)
                         Yrr(N, 6) = Drr(1, 4)
                     Next x
                  End If
               End If
           Next k
       Next j
       '-----------------------------------
       If N <= 1 Then GoTo i01
       Set vS = Sheets.Add(after:=vS): vS.Name = S
       With vS.[a1].Resize(N, 6)
            .Value = Yrr
            .Borders.LineStyle = 1
            .Sort Key1:=.Item(3), Order1:=xlAscending, _
                  Key2:=.Item(4), Order2:=xlAscending, _
                  Key3:=.Item(2), Order3:=xlAscending, Header:=xlYes
            T = "'" & S & "'!" & .Address
       End With
       '-----------------------------------
       ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=T).CreatePivotTable TableDestination:=vS.Range("i1"), TableName:="Pvt_1"
       vS.PivotTables("Pvt_1").AddFields RowFields:=vS.Range("C1"), ColumnFields:=vS.Range("d1")
       vS.PivotTables("Pvt_1").PivotFields(vS.Range("F1").Text).Orientation = xlDataField
    End If
    Application.CommandBars("PivotTable").Visible = False
i01: Next i
End Sub

Sub 刪除工作表()
Dim xS As Worksheet
Application.DisplayAlerts = False
For Each xS In Sheets
    If xS.Name Like "[#]###" Then xS.Delete
Next
End Sub

TOP

回復 16# 准提部林


    未免因爲中文亂碼無法運行,改了英文,但是出來的答案跟需求不一樣。
第一, 序號不是COPY  “SR/排架表" 堛漣К飽A而是每次按順序
第二,樓層有部分也不是根據“SR/排架表" 媦蚍h
第三, 單元應該也是按照“SR/排架表" 堻璊衙爸,不過出來的是所有貨架序號堛熔臚@個單元
舉例 下面是SR / 拍架表
序号        货架编号        货架序号        单元        数量        楼层
8                      GS201        SR2001                 FC130               1        02F       
9                                                                 FC117          1        02F       
10                                                                 FC116               1        02F       
11                                                                 FC133            1        06F       
12                                                                 FC117                1        02F       
13                                                                 FC118                1        06F       
14                                                                 FC133                1        06F       
然後BF 堶惘袖R2001
出來的效果是下面這樣,就是直接COPY SR2001堶悸漫狾内容,然後貨架和貨架序號變成不合并,而且填滿每行。
序号        货架编号        货架序号        楼层        单元        数量
8                 GS201                 SR2001         02F                 FC130           1
9                 GS201                 SR2001                02F                 FC117           1
10                 GS201                 SR2001                02F          FC116           1
11                 GS201                 SR2001          02F          FC130       1
12                 GS201           SR2001                02F          FC117            1
13                 GS201                 SR2001                02F          FC116            1
14                 GS201                 SR2001                 02F         FC130             1

SR.rar (216.5 KB)

排架表.rar (571.34 KB)

TOP

回復 17# 198188

疏忽沒改到//
Yrr(N, 4) = Drr(1, 5)
Yrr(N, 5) = Drr(1, 3)
Yrr(N, 6) = Drr(1, 4)
改成//
Yrr(N, 4) = Drr(x, 5)
Yrr(N, 5) = Drr(x, 3)
Yrr(N, 6) = Drr(x, 4)

TOP

回復 17# 198188

序號是用公式, 右方的有排序, 若不想排序就去掉吧!!!

TOP

回復 19# 准提部林

    Yrr(N, 1) = "=row()-1" 刪除了這個后,序號便空白,怎樣才能讀取SR 的相應序號?我試過改下面的方式,都顯示錯誤,不能執行程式。
     Yrr(N, 1) = Drr(x, -1)
     Yrr(N, 1) = Drr(x, 0)
     Yrr(N, 1) = Drr(1, -1)
     Yrr(N, 1) = Drr(1, 0)

TOP

        靜思自在 : 能幹不幹,不如苦幹實幹。
返回列表 上一主題