­ã´£³¡ªL

¨Ï¥Î°}¦C³B²z//AÄ椣¦X¨Ö¤]¥i¥H..¥u»{«DªÅ
Sub Test_A1()
Dim Arr, Brr, i&, j%, R&, Rx&, C%, X%, T$
Arr = Range([f1], [a65536].End(3).MergeArea)
ReDim Brr(1 To UBound(Arr) * 5, 1 To 99)
For i = 3 To UBound(Arr)
    T = Split(Arr(i, 1) & " ", " ")(0)
    If T Like "BF¤uµ{[#]###" Then C = C + 1: R = 1: Brr(R, C) = T
    For j = 2 To UBound(Arr, 2)
        T = Split(Arr(i, j) & " ", " ")(1)
        If T Like "SR####(*" Then R = R + 1: Brr(R, C) = Split(T, "(")(0)
    Next j
    If R > Rx Then Rx = R
Next i
With Range("H2")
     .CurrentRegion.Clear
     .Resize(Rx, C) = Brr
End With
End Sub

­ã´£³¡ªL

¦^´_ 7# 198188


°õ¦æ¨S°ÝÃD!!!
split ¥Î¨Ó¤À³Î¤å¦r, "(" ¬O¤À³Î²Å

­ã´£³¡ªL

¦^´_ 9# 198188

¥ýµ¹"°e³f³æ"//
µ{¦¡½X¨S¤°¯S§O~~
Xl0000113-°e³f³æ.rar (157.61 KB)

¤U¸ü¦¸¼Æ: 10

2023-12-31 11:45

­ã´£³¡ªL

¦^´_ 9# 198188

±Æ¬[ªí..°j°é¦h¼h, ¦Û¦æ¬ã¨s//
Xl0000114-±Æ¬[ªí.rar (83.4 KB)

¤U¸ü¦¸¼Æ: 6

2024-1-1 13:03

­ã´£³¡ªL

¡Õ°e³f³æ¡Ö

Sub ¨ú¥X¸ê®Æ()
Dim Arr, Xrr, Yrr, i&, j%, V, T$, T1$, TR, x&, y&
Call ²M°£¸ê®Æ
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 Ä榳¤Ø¤oªº¼Æ¾Ú
       Xrr(x, 2) = T1 '³f¬[¸¹
       Xrr(x, 3) = Arr(i, 2) 'N.W.(²b­«)
       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 '³f¬[¸¹
       Yrr(y, 2) = Arr(i, 7) '¦ì¸m
       Yrr(y, 3) = Arr(i, 6) '¤º®e
       Yrr(y, 4) = V '¼Æ¶q
    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 ²M°£¸ê®Æ()
Range([T3], [N65536].End(xlUp)(3)).Delete Shift:=xlUp
Range([Y3], [V65536].End(xlUp)(3)).Delete Shift:=xlUp
End Sub

­ã´£³¡ªL

¡Õ±Æ¬[ªí¡Ö

Sub ©î¤À¤u§@ªí()
Dim Arr, Brr, Drr, Xrr, Yrr, xD, xS As Worksheet, vS As Worksheet, R&, S$, T$, i&, j&, k%, x&, y%, N&
Call §R°£¤u§@ªí
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¤uµ{[#]###*" 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 §R°£¤u§@ªí()
Dim xS As Worksheet
Application.DisplayAlerts = False
For Each xS In Sheets
    If xS.Name Like "[#]###" Then xS.Delete
Next
End Sub

­ã´£³¡ªL

¦^´_ 17# 198188

²¨©¿¨S§ï¨ì//
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)

­ã´£³¡ªL

¦^´_ 17# 198188

§Ç¸¹¬O¥Î¤½¦¡, ¥k¤èªº¦³±Æ§Ç, ­Y¤£·Q±Æ§Ç´N¥h±¼§a!!!

­ã´£³¡ªL

¦^´_ 20# 198188

¼ÒÀÀªº¬Ý¤£¥X¨Ó¦p¦ó°µ§Ç¸¹, ¤§«e¥Î²qªº//
Xl0000191-±Æ¬[ªí.rar (100.48 KB)

¤U¸ü¦¸¼Æ: 8

2024-1-3 14:08