n7822123

回復 10# b9208

嚐試於工作表2同時輸出入口及出口統計表，程式執行錯誤

因為工作表 Outq 的表格左上還是[B6] 跟工作表2 入口表格一致

但是工作表2  出口表格左上變成 [P6] ，準大的程式要再修改位置才能正常執行

不過出口入口程式邏輯一樣，只有抓的位置與輸出的位置不同，我覺得沒必要改2段程式

出口、入口可以合併寫，我也自己寫了一段，並加大彈性

N1~N4, S1~S5 順序隨便給也沒關係，都可以找的到對應，可以參考看看

程式如下

Sub 統計入口()
[B6].CurrentRegion.Offset(2).Clear
統計 [B6], 8
End Sub
Sub 統計出口()
[P6].CurrentRegion.Offset(2).Clear
統計 [P6], 9
End Sub
Sub 統計(ByVal cel0 As Range, Ci As Long)
Dim D, Arr, Brr, T$, K1$, K2$, Key, R&, Ro&, Co&, Rg As Range
Set D = CreateObject("Scripting.Dictionary")
Arr = [資料!A4].CurrentRegion
For R = 2 To UBound(Arr)
  K1 = Arr(R, 2): K2 = Arr(R, Ci)
  If K1 <> T Then Ro = Ro + 1: D(K1) = Ro: T = K1
  If K2 <> "" Then Key = K1 & "-" & K2: D(Key) = D(Key) + 1
Next
ReDim Brr(1 To Ro, 1 To 11)
For Each Key In D.keys
  If InStr(Key, "-") = 0 Then Brr(D(Key), 1) = Key: GoTo 下個Key
  Ro = D(Split(Key, "-")(0))
  Set Rg = cel0.Resize(, 10).Find(Split(Key, "-")(1), , , xlWhole)
  If Not Rg Is Nothing Then
    Co = Rg.Column - cel0.Column + 1
    Brr(Ro, Co) = D(Key): Brr(Ro, 11) = Brr(Ro, 11) + D(Key)
  End If
下個Key: Next
With cel0(2).Resize(Ro, 11)
  .Value = Brr: .Borders.LineStyle = 1
  .VerticalAlignment = xlBottom
  .HorizontalAlignment = xlCenter
End With
End Sub

檔案如下

W2-0822.rar (62.23 KB)

下載次數: 3

2020-8-22 01:11

准提部林

回復 10# b9208

Sub TEST_T()
Dim Arr, Brr, Crr, xD, i&, K, R&, C&, N1&, N2&
Set xD = CreateObject("Scripting.Dictionary")
[工作表2!B7:B2000].EntireRow.Delete
Arr = [工作表2!B6:K6]
For i = 2 To UBound(Arr, 2): xD(Arr(1, i)) = i: Next
Arr = Range([資料!A1], Sheets("資料").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11):  Crr = Brr
For i = 5 To UBound(Arr)
    K = Arr(i, 2): If K = "" Then GoTo 101
    R = Val(xD(K)): C = Val(xD(Arr(i, 8)))
    If C > 0 Then
       If R = 0 Then N1 = N1 + 1: R = N1: xD(K) = R: Brr(R, 1) = K
       Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
    End If
    '--------------------------------
    R = Val(xD(K & "/")): C = Val(xD(Arr(i, 9)))
    If C > 0 Then
       If R = 0 Then N2 = N2 + 1: R = N2: xD(K & "/") = R: Crr(R, 1) = K
       Crr(R, C) = Crr(R, C) + 1: Crr(R, 11) = Crr(R, 11) + 1
    End If
101: Next i
With [工作表2!B7].Resize(N1, 11)
     .Value = Brr
     .Borders.LineStyle = 1
End With
With [工作表2!P7].Resize(N2, 11)
     .Value = Crr
     .Borders.LineStyle = 1
End With
End Sub

分開寫較好解讀~~


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

b9208

回復 11# n7822123
龍大
非常感謝
執行ok

b9208

回復 12# 准提部林
准大
非常感謝
分開寫比較清楚及容易閱讀

准提部林

Sub TEST_T2()
Dim Arr, Brr, xD, i&, j%, K, R&, C&, N&(1)
Set xD = CreateObject("Scripting.Dictionary")
[工作表2!B7:B2000].EntireRow.Delete
Arr = [工作表2!B6:K6]
For i = 2 To UBound(Arr, 2): xD(Arr(1, i) & "") = i: Next
Arr = Range([資料!A1], Sheets("資料").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11):  xD(0) = Brr:  xD(1) = Brr
For i = 5 To UBound(Arr)
    K = Arr(i, 2): If K = "" Then GoTo i01
    For j = 0 To 1
        R = xD(K & j): C = xD(Arr(i, 8 + j) & ""): Brr = xD(j)
        If C = 0 Then GoTo j01
        If R = 0 Then N(j) = N(j) + 1: R = N(j): xD(K & j) = R: Brr(R, 1) = K
        Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
        xD(j) = Brr
j01: Next j
i01: Next i
For j = 0 To 1
    With Sheets("工作表2").Range(Array("B7", "P7")(j)).Resize(N(j), 11)
         .Value = xD(j)
         .Borders.LineStyle = 1
    End With
Next j
End Sub

做個小迴圈, 有點繞~~


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

b9208

回復 11# n7822123
龍大
「資料」工作表B2, B3儲存格如果非空格，則輸出時，會在標題下增加二行。（如附件）
W2-0823.rar (28.66 KB)

下載次數: 6

2020-8-23 12:45

n7822123

回復 16# b9208 '

因為這是Ctrl+A (CurrentRegion)的效果......原來第3列不一定會是空白阿

修改Arr抓取資料範圍就可以了

程式如下

Sub 統計入口()
[B6].CurrentRegion.Offset(2).Clear
統計 [B6], 8
End Sub
Sub 統計出口()
[P6].CurrentRegion.Offset(2).Clear
統計 [P6], 9
End Sub
Sub 統計(ByVal cel0 As Range, Ci As Long)
Dim D, Arr, Brr, T$, K1$, K2$, Key, R&, Ro&, Co&, Rg As Range
Set D = CreateObject("Scripting.Dictionary")
Arr = [資料!A4].Resize([資料!B4].End(4).Row - 3, 9)
For R = 2 To UBound(Arr)
  K1 = Arr(R, 2): K2 = Arr(R, Ci)
  If K1 <> T Then Ro = Ro + 1: D(K1) = Ro: T = K1
  If K2 <> "" Then Key = K1 & "-" & K2: D(Key) = D(Key) + 1
Next
ReDim Brr(1 To Ro, 1 To 11)
For Each Key In D.keys
  If InStr(Key, "-") = 0 Then Brr(D(Key), 1) = Key: GoTo 下個Key
  Ro = D(Split(Key, "-")(0))
  Set Rg = cel0.Resize(, 10).Find(Split(Key, "-")(1), , , xlWhole)
  If Not Rg Is Nothing Then
    Co = Rg.Column - cel0.Column + 1
    Brr(Ro, Co) = D(Key): Brr(Ro, 11) = Brr(Ro, 11) + D(Key)
  End If
下個Key: Next
With cel0(2).Resize(Ro, 11)
  .Value = Brr: .Borders.LineStyle = 1
  .VerticalAlignment = xlBottom
  .HorizontalAlignment = xlCenter
End With
End Sub

b9208

回復 17# n7822123
龍大
非常抱歉，輸出部分再增加「星期」欄位（如附件）。
有試這自己修訂，但是沒有成功，功力不足。
謝謝
W2-0824.rar (28.88 KB)

下載次數: 0

2020-8-24 20:22

b9208

回復 15# 准提部林
准大
懇請協助於工作表2內增加輸出「星期」欄位，非常感謝。
   Q3.rar (29.4 KB)

下載次數: 1

2020-8-25 21:30

准提部林

回復 19# b9208

加了註解, 慢慢看:
Xl0000235.rar (20.83 KB)

下載次數: 14

2020-8-26 11:05

因考慮[入口/出口]的日期資料可能不一致,
例如:7/1..入口有資料, 出口沒資料, 那兩表的列數就不相同,
所以還是兩表分別判斷~~