標題: [發問] 依條件複製不同工作表資料並統計不重複次數 [打印本頁]

---

作者: b9208    時間: 2020-12-4 12:15     標題: 依條件複製不同工作表資料並統計不重複次數

依據「總表」A欄條件，比對NL及SL工作表內〞部門〞欄位，相同則複製資料列至「總表」，並依條件統計不重複列次數輸出至「統計」工作表。
敬請各位前輩指導
非常感謝

[attach]32759[/attach]

---

作者: 准提部林    時間: 2020-12-7 17:00

參考檔
[attach]32770[/attach]

四段分開寫, 意思差不多, 自行研究下~~

---

作者: b9208    時間: 2020-12-8 15:10

回復 2# 准提部林
非常感謝幫忙與指導
執行後下列二項問題：
一、        總表未依「日期」與「名稱」排序
二、        統計之計數需要排除條件相同的重復列（本項懇請幫忙）
再次感謝

---

作者: 准提部林    時間: 2020-12-8 19:06

回復 3# b9208

[attach]32772[/attach]
   
統計表的格式(標題行), 與所述條件不一致~~
自行參酌程式修改

---

作者: b9208    時間: 2020-12-9 13:13

回復 4# 准提部林
前輩
非常抱歉，漏了很重要一個條件。
重要條件：「日期 & 部門 & 名稱 & 料號（前7碼）」等相同列，只計數1次。（詳附件）

另請教程式碼  If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "//a") = 1，中之「"//a"」的作用？
非常感謝

[attach]32777[/attach]

---

作者: 准提部林    時間: 2020-12-10 16:12

回復 5# b9208


__還是看不懂統計表的規則__
「日期 & 部門 & 名稱 & 料號（前7碼）」等相同列，只計數1次。
一、依據「名稱」統計，輸出於A表。
二、依據「地區」統計，輸出於B表。
二、依據「部門」統計，輸出於C表。

---

作者: b9208    時間: 2020-12-10 20:23

回復 6# 准提部林
准大
增加條件或許加在「總表」比較適當（如下紅字）
需求說明：「總表」工作表
一、依據「總表」A欄「篩選部門」條件，比對NL及SL工作表〞部門〞欄位，相同則複製資料列至「總表」。
二、「日期 & 部門 & 名稱 & 料號（前7碼）」相同者，只選擇「數量」最大值者複製乙筆資料列，其他資料列捨棄不複製。
三、依據「日期」及「名稱」排序
  [attach]32784[/attach]

---

作者: 准提部林    時間: 2020-12-11 11:18

回復 7# b9208


先做總表:
[attach]32787[/attach]

統計表自行先摹擬結果, 看不懂~~

---

作者: b9208    時間: 2020-12-11 16:57

回復 8# 准提部林
准大
非常感謝
依據總表結果，增加統計程式。執行符合需求。
功力不足，無法合併成一個程式執行。

[attach]32789[/attach]

---

作者: 准提部林    時間: 2020-12-12 11:46

回復 9# b9208

參考檔:
[attach]32796[/attach]

統計做兩個, 懂哪個就用哪個

---

作者: b9208    時間: 2020-12-16 09:50

回復 10# 准提部林
Dear 前輩！非常感謝
如於執行前判斷NL或SL工作表是否存在？不存在則結束執行，如下如何更改。謝謝！
Dim ws As Worksheet
Dim sName As String
sName = "NL"
On Error Resume Next
Set ws = Sheets(sName)
If ws Is Nothing Then
    MsgBox "NL or SL工作表不存在結束執行"
    Exit Sub
End If

---

作者: 准提部林    時間: 2020-12-16 10:54

回復 11# b9208

For Each S In Array("NL", "SL")
    On Error Resume Next
    If Sheets(S & "") Is Nothing Then
       MsgBox "工作表:〔" & S & "〕不存在! ": Exit Sub
    End If
    On Error GoTo 0
Next

---

作者: b9208    時間: 2020-12-19 00:03

回復 12# 准提部林
Dear 准大
非常感謝
如將所有資料移動複製到主檔，主檔檔案會變很大（約30多MB）。
請問可以不用將資料移到主檔，就可以依篩選條件複製資料到主檔嗎？
主檔名稱：TOTAL
資料檔名稱：Data1, 2, 3…….（工作表名稱：LIST）
以上檔案同一資料夾
謝謝
[attach]32835[/attach]

---

作者: 准提部林    時間: 2020-12-19 09:19

回復 13# b9208


附檔:
[attach]32842[/attach]

---

作者: b9208    時間: 2021-2-6 23:24

回復 14# 准提部林

准大您好
請教想要於「TOTAL 總表」B2儲存格值複製其他EXCEL檔內A2的值（其他檔案內A2值都是相同的），如何修訂巨集？
懇請指導
謝謝！
[attach]33039[/attach]

---

作者: 准提部林    時間: 2021-2-7 09:31

回復 15# b9208


  Set xB = Workbooks.Open(PH & "\" & FN, ReadOnly:=True)
   Set xS = xB.Sheets(1)
   If DateStr = "" Then DateStr = xS.[A2]
   Arr = Range(xS.[A1:O1], xS.UsedRange)


If M > 0 Then
   [總表!b2] = DateStr

end if

插入紅色字那二行~~

---

作者: b9208    時間: 2021-2-7 13:26

回復 16# 准提部林

准大
非常感謝

---

作者: Andy2483    時間: 2022-12-5 16:36

本帖最後由 Andy2483 於 2022-12-5 16:45 編輯

回復 14# 准提部林


    謝謝 准提部林前輩指導
謝謝 b9208前輩發表此主題與範例
後學藉此帖習得很多知識,謝謝論壇
執行細節與心得註解如下,請前輩再指導!謝謝

執行前:
[attach]35560[/attach]

執行後:
[attach]35561[/attach]

Option Explicit
Sub TEST_總表()
Dim Arr, Brr, xD, PH$, FN$, i&, j&
'↑宣告(Arr, Brr, xD)是通用型變數,(PH$, FN$)是字串變數,(i,j)是長整數變數
Dim xB As Workbook, xS As Worksheet, TT$, T$(4), M&, U&
'↑宣告(xB)是活頁簿變數,(xS)是工作表變數,
'(TT)是字串變數,T是5個元素的一維字串陣列變數,(M&,U&)是長整數變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD 是字典
PH = ThisWorkbook.Path
'↑令PH字串變數是 現在這活頁簿的所在檔案位置
Call 清除_總表
'↑執行 副程式 清除_總表()
'--------------------------
Arr = Range([總表!a1], [總表!a65536].End(xlUp))
'↑令Arr是陣列!倒入"總表"工作表[A1]到"總表"工作表A欄最後一個有內容的儲存格
For i = 2 To UBound(Arr)
'↑設順迴圈i從2 到Arr陣列縱向最大列號
    If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "//a") = 1
    '↑如果Arr陣列迴圈列第一欄的值不是 空字元!
    '就以Arr陣列迴圈列第一欄的值 連接 "//a" 字串 當xD字典的KEY,
    'item是數字1
Next i
ReDim Brr(1 To 2000, 1 To 15)
'↑宣告Brr陣列的範圍!縱向從1到2000列,橫向從1到15欄
'--------------------------
Application.ScreenUpdating = False
'↑螢幕畫面不跟著執行程序變化
Do
'↑設無限迴圈!開始執行後面的程序,自己想辦法跳出迴圈
   If FN = "" Then
   '↑如果FN字串變數是 空字元??
      FN = Dir(PH & "\*.xls")
      '↑令FN字串變數是 現在這活頁簿的所在檔案位置的EXCEL檔案
      Else
         FN = Dir
         '↑FN逐次抓取相同路徑下的當名
         'https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/dir-function
   End If
   If FN = "" Then Exit Do
   '↑如果FN字串變數是空字元!代表相同路徑下的檔名已經都抓過了,就跳出Do~Loop的迴圈
   If FN = ThisWorkbook.Name Then GoTo DP
   '↑如果FN字串變數是 現在這活頁簿的名稱字串!就跳到 DP 位置繼續執行
   '--------------------------
   Set xB = Workbooks.Open(PH & "\" & FN, ReadOnly:=True)
   '↑令xB 是以唯讀方式打開 PH字串變數 & "\" & FN字串變數組合成字串的活頁簿
   Set xS = xB.Sheets(1)
   '↑令xS 是打開的這活頁簿的第一個工作表
   Arr = Range(xS.[A1:O1], xS.UsedRange)
   '↑令Arr倒掉原來的陣列值!變成新陣列,倒入打開的活頁簿第一個表全部有使用的儲存格值
   For i = 6 To UBound(Arr)
   '↑設外順迴圈!i從6到Arr陣列縱向最大列號
       T(1) = Arr(i, 6)
       '↑令T一維陣列的第二個字串是i迴圈數第六欄Arr陣列值
       T(2) = Arr(i, 8)
       '↑令T一維陣列的第三個字串是i迴圈數第八欄Arr陣列值
       T(3) = Left(Arr(i, 9), 7)
       '↑令T一維陣列的第四個字串是i迴圈數第九欄Arr陣列值的左邊7個字元
       T(4) = Arr(i, 3)
       '↑令T一維陣列的第五個字串是i迴圈數第三欄Arr陣列值
       If T(1) = "" Or xD(T(1) & "//a") = 0 Then
       '↑如果T陣列的第二個字串是 空字元 或
       '以 T陣列的第二個字串連接 "//a"字串查察xD字典 是0??
          GoTo 101
          '↑條件成立!就跳到 101的位置繼續執行
       End If
       TT = T(1) & "|" & T(2) & "|" & T(3) & "|" & T(4)
       '↑令TT字串變數是T陣列裡第二個字串到第五個字串中間連接"|"符號的字串
       U = xD(TT)
       '↑令U 是以TT字串為key查察xD字典得到的Item值,轉為整數數字
       If U = 0 Then
       '↑如果U 是0,這判斷式是要排除重複!第一次出現的TT字串才會條件成立
          M = M + 1
          '↑令M累加1
          U = M
          '↑令U 裝M的值(整數數字)
          xD(TT) = U
          '↑以TT字串當key,Item是 U數字變數
       End If
       If Arr(i, 11) > Brr(U, 11) Or Brr(U, 11) = Empty Then
       '↑如果迴圈列數第11欄的Arr陣列值 大於U列第11欄的Brr陣列值,
       '或U列第11欄的Brr陣列值是初始值(沒變過)
          For j = 1 To UBound(Brr, 2)
          '↑設內順迴圈!j從1 到Brr陣列橫向最大欄號
             Brr(U, j) = Arr(i, j)
             '↑U列號 j內迴圈欄號的Brr陣列值 = 外迴圈i列號 j內迴圈欄號的Arr陣列值
          Next
          Brr(U, 9) = Left(Brr(U, 9), 7)
          '↑U列號 第9欄號的Brr陣列值 = 自己的值取左側的7 個字元
       End If
101: Next i
   xB.Close 0
   '↑關閉被開啟的 xB活頁簿變數檔案(不存檔)
DP: Loop
'↑無限迴圈的轉折點!跳到前面的Do位置繼續執行!
'--------------------------
If M > 0 Then
'↑如果M整數變數大於0 (這裡的M 指的是 原本Brr(1 To 2000, 1 To 15)空陣列被使用的列數)
   With [總表!b6].Resize(M, UBound(Brr, 2))
   '↑以下關於 "總表"工作表[B6]向下擴展M列,向右擴展Brr陣列橫向最大欄號數欄 的儲存格區域
         .Value = Brr
         '↑這擴展區域儲存格以Brr陣列值倒入
         .Borders.LineStyle = 1
         '↑令這擴展區域儲存格的格線樣式是 細實線
         .Sort key1:=.Item(3), Order1:=xlAscending, _
               key2:=.Item(8), Order2:=xlAscending, Header:=xlNo
         '↑這擴展區域儲存格做兩層次的整列排序,細節如下:
         '1.將這擴展區域儲存格的相對第三欄位(表裡的 D欄),做小到大的排序
         '2.並將一次排序後裡面相同值,再對相對第八欄位(表裡的 I欄),做小到大的排序
   End With
End If
Set Arr = Nothing
Set Brr = Nothing
Set xD = Nothing
End Sub
Sub 清除_總表()
Sheets("總表").UsedRange.Offset(5, 0).Offset(, 1).Delete Shift:=xlUp
'↑"總表"工作表有使用的儲存格範圍,往下偏移5列,左右不偏移,之後再往右偏移1欄,
'此儲存格範圍刪除!並由下方的儲存格往上遞補

'Offset(5, 0).Offset(, 1) = Offset(5, 0).Offset(0 , 1)
'Offset(5, 0).Offset(, 1) = Offset(5).Offset( , 1)
'Offset(5, 0).Offset(, 1) = Offset(5, 1)
'Offset(5,  ).Offset(, 1) 會出現 編譯錯誤
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.offset
End Sub

---

作者: Andy2483    時間: 2022-12-6 08:56

本帖最後由 Andy2483 於 2022-12-6 09:05 編輯

回復 14# 准提部林


        再次謝謝 准提部林前輩指導
再次謝謝 b9208前輩發表此主題與範例
後學藉此帖習得很多知識,謝謝論壇
這範例用了多個陣列處理,頭腦快打結了,謝謝
執行細節與心得註解如下,請前輩再指導!謝謝

執行前:
[attach]35562[/attach]

執行後:
[attach]35563[/attach]

Option Explicit
Sub TEST_統計_1()
Dim Arr, Xrr, Yrr, Zrr, xD, i&, U&, TT$, j%, T$(4), N&(3)
'↑宣告(Arr, Xrr, Yrr, Zrr, xD)是通用型變數,(i,U)是長整數,
'(TT)是字串變數,(j)是短整數,(T)是5個字串的一維陣列,
'(N)是4個長整數的一維陣列
[統計!c4:q3000].Delete Shift:=xlUp
'↑令"統計" 工作表的 [c4:q3000]儲存格刪除!
'空位由下方儲存格往上遞補
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典
Arr = Range([總表!M1], [總表!G65536].End(xlUp))
'↑令Arr是字典!倒入"總表"工作表[M1]到 G欄最後一有內容儲存格範圍,
'的儲存格值
ReDim Xrr(1 To UBound(Arr), 1 To 4)
'↑宣告Xrr是二維陣列!範圍是:
'縱向從1 到Arr陣列縱向最大列號數,橫向從1 到4
Yrr = Xrr
'↑令Yrr 也是二維陣列!範圍大小同 Xrr
Zrr = Xrr
'↑令Zrr 也是二維陣列!範圍大小同 Xrr
For i = 6 To UBound(Arr)
'↑設外順迴圈!i從6 到Arr陣列縱向最大列號數
   T(1) = Arr(i, 1)
   '↑令T陣列的第2個字串是i迴圈數列第1欄的Arr陣列值
   T(2) = Arr(i, 3)
   '↑令T陣列的第3個字串是i迴圈數列第3欄的Arr陣列值
   T(3) = Arr(i, 4)
   '↑令T陣列的第4個字串是i迴圈數列第4欄的Arr陣列值
   T(4) = Arr(i, 7)
   '↑令T陣列的第5個字串是i迴圈數列第7欄的Arr陣列值
   '------------------------------
   TT = T(1) & "|" & T(2) & "|" & T(3)
   '↑令TT字串變數是 T陣列的第2~4個字串中間連接"|"符號的新字串
   U = xD(TT)
   '↑令U是 以TT字串為key查察xD字典的item值,
   '一開始的U值都是初始值0,因為在迴圈之前U都沒出現過
   If U = 0 Then
   '↑如果U 是0 ??
      N(1) = N(1) + 1
      '↑if條件成立!就讓長整數N陣列的第2個數字累加1
      U = N(1)
      '↑if條件成立!就讓U這長整數變數裝 N陣列的第2個數字
      xD(TT) = U
      '↑令TT字串變數是key,item是U長整數變數值!倒入字典裡
      For j = 1 To 3
      '↑設內順迴圈j從1 到3
         Xrr(U, j) = T(j)
         '↑令U列j迴圈欄的Xrr陣列值是 T這一維陣列的第j迴圈數索引位置字串
      Next
   End If
   Xrr(U, 4) = Xrr(U, 4) + 1
   '↑令U列第4欄的Xrr陣列值累加1
   '------------------------------
   TT = T(1) & "|" & T(4)
   '↑令TT字串變數是T陣列第2個字串連接"|"字元,
   '再連接 T陣列第5個字串的新字串
   U = xD(TT)
   '↑令U是 以TT字串為key查察xD字典的item值
   If U = 0 Then
   '↑如果U 是0 ??
      N(2) = N(2) + 1
      '↑if條件成立!就讓長整數N陣列的第3個數字累加1
      U = N(2)
      '↑if條件成立!就讓U這長整數變數裝 N陣列的第3個數字
      xD(TT) = U
      '↑令TT字串變數是key,item是U長整數變數值!倒入字典裡
      Yrr(U, 1) = T(1)
      '↑令U列第1欄的Yrr陣列值是 T陣列的第2個字串
      Yrr(U, 2) = T(4)
      '↑令U列第2欄的Yrr陣列值是 T陣列的第5個字串
   End If
   Yrr(U, 3) = Yrr(U, 3) + 1
   '↑令U列第3欄的Yrr陣列值累加1
   '------------------------------
   TT = T(1)
   '↑令TT字串是 T陣列的第2個字串
   U = xD(TT)
   '↑令U是 以TT字串為key查察xD字典得到的item值
   If U = 0 Then
   '↑如果U 是0 ??
      N(3) = N(3) + 1
      '↑令N陣列的第4個數字累加1
      U = N(3)
      '↑令U 是N陣列裡的第4個數字
      xD(TT) = U
      '↑令TT字串當key,U數字當item 倒入xd字典裡
      Zrr(U, 1) = T(1)
      '↑令U列第1欄的Zrr陣列值是 T陣列的第2個字串
   End If
   Zrr(U, 2) = Zrr(U, 2) + 1
   '↑令U列第2欄的Zrr陣列值累加1
Next i
'------------------------------------
If N(1) > 0 Then
'↑如果N陣列第2個數字 大於0 ??
   With [統計!c4].Resize(N(1), 4)
   '↑以下是關於"統計" 工作表[C4]向下擴展(N陣列第2個數字)列數,
   '向右擴展4欄儲存格範圍的程序
      .Value = Xrr
      '↑令擴展範圍儲存格以 Xrr陣列直到進去
      .Borders.LineStyle = 1
      '↑令擴展範圍儲存格的格線樣式是 細實線
      .Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
      '↑這擴展區域儲存格做一層次的整列排序,細節如下:
         '將這擴展區域儲存格的相對第1欄位(表裡的 C欄),做小到大的排序,
         '沒有標題
   End With
End If
If N(2) > 0 Then
'↑如果N陣列第2個索引位置的數字值 大於0 ??
   With [統計!j4].Resize(N(2), 3)
   '↑以下是關於"統計" 工作表[J4]向下擴展(N陣列第3個數字)列數,
   '向右擴展3欄儲存格範圍的程序
      .Value = Yrr
      '↑令擴展範圍儲存格以 Yrr陣列直到進去
      .Borders.LineStyle = 1
      '↑令擴展範圍儲存格的格線樣式是 細實線
      .Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
      '↑這擴展區域儲存格做一層次的整列排序,細節如下:
       '將這擴展區域儲存格的相對第1欄位(表裡的 J欄),做小到大的排序,
       '沒有標題
   End With
End If
If N(3) > 0 Then
'↑如果N陣列第4個數字 大於0 ??
   With [統計!p4].Resize(N(3), 2)
   '↑以下是關於"統計" 工作表[P4]向下擴展(N陣列第4個數字)列數,
   '向右擴展2欄儲存格範圍的程序
      .Value = Zrr
      '↑令擴展範圍儲存格以 Zrr陣列直到進去
      .Borders.LineStyle = 1
      '↑令擴展範圍儲存格的格線樣式是 細實線
      .Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
      '↑這擴展區域儲存格做一層次的整列排序,細節如下:
       '將這擴展區域儲存格的相對第1欄位(表裡的 P欄),做小到大的排序,
       '沒有標題
   End With
End If
Set Arr = Nothing: Set Xrr = Nothing: Set Yrr = Nothing
Set Zrr = Nothing: Set xD = Nothing: Erase T, N
End Sub

---

作者: Andy2483    時間: 2022-12-6 11:44

本帖最後由 Andy2483 於 2022-12-6 11:51 編輯

回復 14# 准提部林


    再次謝謝 准提部林前輩指導
再次謝謝 b9208前輩發表此主題與範例
後學藉此帖練習以字典的一維陣列ITEM轉置成結果,得很多知識,謝謝論壇
這範例用 准提部林前輩的程式架構再多一個字典與一維陣列做變化,結果稍有不同
執行細節與心得註解如下,請前輩再指導!謝謝
執行後:
[attach]35564[/attach]

Option Explicit
Sub TEST_總表_轉置()
Dim Arr, Y, Z, Q, PH$, FN$, i&, j&, V$(14)
'↑宣告(Arr, Y, Z, Q)是通用型變數,(PH$, FN$)是字串變數,(i,j)是長整數變數,
'V是15個元素的一維字串陣列變數
Dim xB As Workbook, xS As Worksheet, TT$, T$(4), M&
'↑宣告(xB)是活頁簿變數,(xS)是工作表變數,
'(TT)是字串變數,T是5個元素的一維字串陣列變數,(M&)是長整數變數
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
'↑令Y,Z 各是字典
PH = ThisWorkbook.Path
'↑令PH字串變數是 現在這活頁簿的所在檔案位置
Call 清除_總表1
'↑執行 副程式 清除_總表1()
'--------------------------
Arr = Range([總表!a1], [總表!a65536].End(xlUp))
'↑令Arr是陣列!倒入"總表"工作表[A1]到"總表"工作表A欄最後一個有內容的儲存格
For i = 2 To UBound(Arr)
'↑設順迴圈i從2 到Arr陣列縱向最大列號
    If Arr(i, 1) <> "" Then Y(Arr(i, 1) & "//a") = 1
    '↑如果Arr陣列迴圈列第一欄的值不是 空字元!
    '就以Arr陣列迴圈列第一欄的值 連接 "//a" 字串 當Y字典的KEY,
    'item是數字1
Next i
Application.ScreenUpdating = False
'↑螢幕畫面不跟著執行程序變化
Do
'↑設無限迴圈!開始執行後面的程序,自己想辦法跳出迴圈
   If FN = "" Then
   '↑如果FN字串變數是 空字元??
      FN = Dir(PH & "\*.xls")
      '↑令FN字串變數是 現在這活頁簿的所在檔案位置的EXCEL檔案
      Else
         FN = Dir
         '↑FN逐次抓取相同路徑下的當名
         'https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/dir-function
   End If
   If FN = "" Then Exit Do
   '↑如果FN字串變數是空字元!代表相同路徑下的檔名已經都抓過了,就跳出Do~Loop的迴圈
   If FN = ThisWorkbook.Name Then GoTo DP
   '↑如果FN字串變數是 現在這活頁簿的名稱字串!就跳到 DP 位置繼續執行
   '--------------------------
   Set xB = Workbooks.Open(PH & "\" & FN, ReadOnly:=True)
   '↑令xB 是以唯讀方式打開 PH字串變數 & "\" & FN字串變數組合成字串的活頁簿
   Set xS = xB.Sheets(1)
   '↑令xS 是打開的這活頁簿的第一個工作表
   Arr = Range(xS.[A1:O1], xS.UsedRange)
   '↑令Arr倒掉原來的陣列值!變成新陣列,倒入打開的活頁簿第一個表全部有使用的儲存格值
   'xS.UsedRange有可能不包含最左上角的儲存格!所以用 xS.[A1:O1]在前方做完整區域儲存格匡列
   For i = 6 To UBound(Arr)
   '↑設外順迴圈!i從6到Arr陣列縱向最大列號
       T(1) = Arr(i, 6)
       '↑令T一維陣列的第二個字串是i迴圈數第六欄Arr陣列值
       T(2) = Arr(i, 8)
       '↑令T一維陣列的第三個字串是i迴圈數第八欄Arr陣列值
       T(3) = Left(Arr(i, 9), 7)
       '↑令T一維陣列的第四個字串是i迴圈數第九欄Arr陣列值的左邊7個字元
       T(4) = Arr(i, 3)
       '↑令T一維陣列的第五個字串是i迴圈數第三欄Arr陣列值
       If T(1) = "" Or Y(T(1) & "//a") = 0 Then
       '↑如果T陣列的第二個字串是 空字元 或
       '以 T陣列的第二個字串連接 "//a"字串查察Y字典 是0??
          GoTo 101
          '↑條件成立!就跳到 101的位置繼續執行
       End If
       TT = T(1) & "|" & T(2) & "|" & T(3) & "|" & T(4)
       '↑令TT字串變數是T陣列裡第二個字串到第五個字串中間連接"|"符號的字串
       If Y.Exists(TT) = Empty Then
       '↑如果 用TT字串變數查察Y字典沒有這個key
          Y(TT) = Arr(i, 11)
          '↑令TT字串變數是key,item是迴圈列數第11欄的Arr陣列值,倒入Y字典裡
          ElseIf Arr(i, 11) > Y(TT) Then
          '↑否則如果 迴圈列數第11欄的Arr陣列值 大於 (TT當key查察Y字典的item值)
              Y(TT) = Arr(i, 11)
              '↑令TT字串變數是key,item是迴圈列數第11欄的Arr陣列值,倒入Y字典裡,
              '如果key重複!就將item置換成新的
              Z.Remove TT
              '↑令Z字典刪除 TT字串變數的key與item
              M = M - 1
              '↑令M減掉 1
       End If
       If Z.Exists(TT) = Empty Then
          M = M + 1
          '↑令M累加1
          Q = V
          '↑令Q 是V一維陣列
          For j = 0 To UBound(Q)
          '↑設內順迴圈!j從0 到Q陣列橫向最大欄號
             Q(j) = Arr(i, j + 1)
             '↑令 j內迴圈索引號的Q陣列值 = 外迴圈i列號 j+1內迴圈欄號的Arr陣列值
          Next
          Q(8) = Left(Q(8), 7)
          '↑8索引號的Q陣列值 = 自己的值取左側的7 個字元
          Z(TT) = Q
          '↑令TT字串變數為key,Item是Q一維陣列
       End If
101: Next i
   xB.Close 0
   '↑關閉被開啟的 xB活頁簿變數檔案(不存檔)
DP: Loop
'↑無限迴圈的轉折點!跳到前面的Do位置繼續執行!
'--------------------------
If M > 0 Then
'↑如果M整數變數大於0 (這裡的M 指的是 Z字典key數量)
   With [總表!b6].Resize(M, UBound(V) + 1)
   '↑以下關於 "總表"工作表[B6]向下擴展M列,向右擴展Q陣列最大索引號+1數欄 的儲存格區域
         .Value = Application.Transpose(Application.Transpose(Z.items))
         '↑這擴展區域儲存格以Z字典的items轉置兩次的值倒入
         .Borders.LineStyle = 1
         '↑令這擴展區域儲存格的格線樣式是 細實線
         .Sort key1:=.Item(3), Order1:=xlAscending, _
               key2:=.Item(8), Order2:=xlAscending, Header:=xlNo
         '↑這擴展區域儲存格做兩層次的整列排序,細節如下:
         '1.將這擴展區域儲存格的相對第三欄位(表裡的 D欄),做小到大的排序
         '2.並將一次排序後裡面相同值的相對第八欄位(表裡的 I欄),做小到大的排序
   End With
End If
Set Arr = Nothing: Set Y = Nothing: Set Z = Nothing
Erase V, T, Q
End Sub
Sub 清除_總表1()
Sheets("總表").UsedRange.Offset(5, 0).Offset(, 1).Delete Shift:=xlUp
'↑"總表"工作表有使用的儲存格範圍,往下偏移5列,左右不偏移,之後再往右偏移1欄,
'此儲存格範圍刪除!並由下方的儲存格往上遞補

'Offset(5, 0).Offset(, 1) = Offset(5, 0).Offset(0 , 1)
'Offset(5, 0).Offset(, 1) = Offset(5).Offset( , 1)
'Offset(5, 0).Offset(, 1) = Offset(5, 1)
'Offset(5,  ).Offset(, 1) 會出現 編譯錯誤
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.offset
End Sub

---

作者: singo1232001    時間: 2023-3-4 06:53

本帖最後由 singo1232001 於 2023-3-4 07:00 編輯

感謝此帖讓我練習 感謝前面各位大大 分享練習檔案


    Sub sql抓檔()
With CreateObject("adodb.connection"): V = Application.Version:
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; "
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; "
.Open V & "Data Source=" & ThisWorkbook.Path & "\" & "Data1.xls"  
For Each Z In Sheets("總表").Range("a2:a15").Value
If Z <> "" Then T = T & ",'" & Z & "'"
Next: T = Mid(T, 2, 9999)
q = "select a.*,cstr(a.日期)+a.部門+a.名稱+left(料號,7) as NN from  [Sheet1$A5:L] as a where a.部門 in(" & T & ") "
Sheets("tmp").Cells.ClearContents
Sheets("tmp").[A1].Resize(1, 14) = Split("a1,a2,日期,a4,a5,部門,a7,名稱,料號,a10,數量,地區,NN,key", ",")
Sheets("tmp").[A2].CopyFromRecordset  .Execute(q)
.Close: .Open V & "Data Source=" & ThisWorkbook.Path & "\" & "Data2.xls"
r = Sheets("tmp").Cells(Rows.Count, 3).End(3).Row
Sheets("tmp").Cells(r + 1, 1).CopyFromRecordset .Execute(q)
.Close: .Open V & "Data Source=" & ThisWorkbook.FullName
Set rs = .Execute("select * from [tmp$A1:N] order by 日期,數量 desc")
Sheets("tmp").Cells(2, 1).CopyFromRecordset rs
r = Sheets("tmp").Cells(Rows.Count, 3).End(3).Row - 1
ReDim ar(1 To r, 0): For i = 1 To r: ar(i, 0) = i: Next
Sheets("tmp").[N2].Resize(r, 1) = ar

q = "select * from ( "
q = q & "SELECT C.a1,C.a2,C.日期,C.a4,C.a5,C.部門,C.a7,C.名稱,C.料號,C.a10,C.數量,C.地區 FROM ("
q = q & " SELECT NN,MIN(KEY) as K FROM [tmp$A1:N] GROUP BY NN "
q = q & " ) B INNER JOIN [tmp$A1:N] C ON B.K = C.KEY"
q = q & " ) D order by D.日期,D.名稱"
Sheets("總表").Cells(6, 2).Resize(1000, 15).ClearContents
Sheets("總表").Cells(6, 2).CopyFromRecordset .Execute(q)
End With
End Sub




Sub sql統計名稱_地區_部門()
With CreateObject("adodb.connection"): V = Application.Version:
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; "
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; "
.Open V & "Data Source=" & ThisWorkbook.FullName
Set s = Sheets("統計")
s.Rows("4:30").ClearContents
q = "select 部門,名稱,料號,count(名稱) as cnt from [總表$B5:P] group by 名稱,料號,部門 order by 部門,名稱,料號 "
s.Range("C4").CopyFromRecordset .Execute(q)
q = "select 部門,地區,count(部門) as cnt from [總表$B5:P] group by 部門,地區 order by 部門,地區 "
s.Range("J4").CopyFromRecordset .Execute(q)
q = "select 部門,count(部門) as cnt from [總表$B5:P] group by 部門 order by 部門 "
s.Range("P4").CopyFromRecordset .Execute(q)
End With: s.Select
End Sub

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)