返回列表 上一主題 發帖

[發問] 項相分類重整

[發問] 項相分類重整

各位大大,

請問我有一個總帳是所有資料都歸納在一個工作表, 但我想按照不同的編號(括號內的數字)複製在另一工作表和加上固定的項目名等稱, 每一個科目之間都會有一行空間相隔,

謝謝

分類帳.rar (124.42 KB)

回復 1# mdr0465


    謝謝前輩發表此主題與範例檔
後學研究過以下連結帖比這帖複雜,請前輩研究看看
http://forum.twbts.com/viewthrea ... a=pageD3&page=1
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

本帖最後由 Andy2483 於 2022-12-22 16:47 編輯

回復 1# mdr0465


    祝各位前輩 冬至平安喜樂
後學今天休假,臨時被召回處裡事情,看了一下這帖
昨天有研究了前輩需求情境,今天測試了一下,先提供給前輩試試看,是否符合需求
先回家了,前輩的留言明天才能回復
請前輩們指導

執行結果:
2022-12-22_163427.JPG
2022-12-22 16:34


Option Explicit
Sub 項相分類重整_20221222_1()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Arr, i&, j&, Brr, Y, N, Ra, Sh
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("結果")
Arr = Range([分類帳!H1], [分類帳!A1].Cells(Rows.Count, 1).End(xlUp))
With Sheets.Add
   With .[A1].Resize(UBound(Arr), UBound(Arr, 2))
      .Value = Arr
      .Sort _
      KEY1:=.Item(1), Order1:=xlAscending, _
      Key2:=.Item(2), Order2:=xlAscending, _
      Header:=xlYes, Orientation:=xlTopToBottom
       Arr = .Value
   End With
   .Delete
End With
For i = 1 To UBound(Arr)
   Y(Arr(i, 1)) = ""
Next
ReDim Brr(1 To UBound(Arr) + Y.Count * 3, 1 To UBound(Arr, 2))
Set Ra = Sh.[A1:H1]
For i = 2 To UBound(Arr)
   If Arr(i, 1) <> Arr(i - 1, 1) Then
      N = IIf(i = 2, N + 1, N + 2)
      Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
      Brr(N, 2) = Arr(i, 1)
      N = N + 1
      Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
      For j = 1 To UBound(Arr, 2)
         Brr(N, j) = Arr(1, j)
      Next
   End If
   
111
   N = N + 1
   Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
   For j = 1 To UBound(Arr, 2)
      Brr(N, j) = Arr(i, j)
   Next
   Brr(N, 2) = "'" & Format(Brr(N, 2), "yyyy-mm-dd")
   Brr(N, 3) = "'" & Brr(N, 3)
Next
Sh.UsedRange.ClearContents
Sh.Cells.Borders.LineStyle = 0
Ra.Borders.LineStyle = 1
Sh.[A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Set Y = Nothing
Set Arr = Nothing
Set Brr = Nothing
End Sub
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 3# Andy2483

Andy師兄,你好

謝謝你的幫忙
這正是我想要的結果,但可不可以再修改一些內容, 我想將所有的" 本日合計" 和"本年累計" 都刪除,謝謝幫忙修改程式

,

TOP

本帖最後由 Andy2483 於 2022-12-23 09:11 編輯

回復 4# mdr0465


    謝謝前輩回復
今天複習修改了一下,請前輩再試試看,心得註解請參考
請各位前輩指導,謝謝

執行結果:
2022-12-23_084459.JPG
2022-12-23 08:54


Option Explicit
Sub 項相分類重整_20221222_1()
Application.DisplayAlerts = False
'↑不要問是不是真的要刪除工作表!乾脆點!
Application.ScreenUpdating = False
'↑螢幕不要跟著程序做變化!偷偷做就好了
Dim i&, j&, N&, St$, Arr, Brr, Y, Z, Ra, Sh
'↑宣告變數:(i,j,N)是長整數變數,St是字串變數,其他是通用型變數
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
'↑令Y,Z各是 字典
Set Sh = Sheets("結果")
'↑令Sh是 "結果"工作表
Arr = Range([分類帳!H1], [分類帳!A1].Cells(Rows.Count, 1).End(xlUp))
'↑令Arr是 二維陣列!倒入從 "分類帳"工作表的[H1]到該表的A欄最後一個有內容儲存格之間,
'擴展成為最小方正區域儲存格的值

With Sheets.Add
'↑以下是有關於新增工作表的程序
   With .[A1].Resize(UBound(Arr), UBound(Arr, 2))
   '↑以下是有關於新增工作表從[A1]擴展縱向Arr陣列最大列號數,橫向Arr陣列最大欄號數,
   '這些儲存格的程序

      .Value = Arr
      '↑儲存格值以 Arr陣列值倒進去
      .Sort _
      KEY1:=.Item(1), Order1:=xlAscending, _
      Key2:=.Item(2), Order2:=xlAscending, _
      Header:=xlYes, Orientation:=xlTopToBottom
      '↑令以第1欄做第一層做有標列的上下順排序,第2欄同時做第二層上下順排序
      Arr = .Value
      '↑令Arr陣列倒掉原來的值,裝入這排序好的儲存格值
   End With
   .Delete
   '↑令這新增工作表刪除
End With
'我想將所有的" 本日合計" 和"本年累計" 都刪除
St = "/本日合計/本年累計/關鍵字|/關鍵字|/"
'↑令St這字串變數是雙引號裡的這些字,關鍵字|是用來給使用者追加的
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1到Arr陣列最大列號數
   Y(Arr(i, 1)) = ""
   '↑令以迴圈列第1欄Arr陣列值當key,item是空字元,放入Y字典裡,
   '這是要統計共有幾種 明細科目,才知道要增加多少標題列

   If InStr(St, "/" & Replace(Arr(i, 4), " ", "") & "/") <> 0 Then
   '↑如果用InStr()函式判斷是不等於 0,怎麼判斷?
   '先用Replace()函式將i迴圈列第4欄Arr陣列值,用""空字元置換掉" "空白字元,
   '再用"/"符號在前後包住這字串,以免誤判
   '去比對St字串變數裡有沒有包含這串字

'https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/instr-function
      Z("合計累計") = Z("合計累計") + 1
      '↑令以"合計累計"字串當key,item累加 1
   End If
Next
ReDim Brr(1 To UBound(Arr) + Y.Count * 3 - 1 - Z("合計累計"), 1 To UBound(Arr, 2))
'↑宣告Brr陣列的範圍大小,縱向從1到Arr陣列最大索引列號數+Y字典key數量*3,減1,
'再減掉 "合計累計"字串當key查Z字典得到的item值
'橫向從1到Arr陣列最大索引欄號數

Set Ra = Sh.[A1:H1]
'↑令Ra這通用型變數是 Sh工作表變數裡的[A1:H1]儲存格
For i = 2 To UBound(Arr)
'↑設外順迴圈!i從2到Arr陣列最大列號數
   If Arr(i, 1) <> Arr(i - 1, 1) Then
   '↑如果i迴圈列第1欄Arr陣列值 不等於(i-1)迴圈列第1欄Arr陣列值
      N = IIf(i = 2, N + 1, N + 2)
      '↑令N這長整數變數的值用 IIf()函式決定,
      '如果i迴圈數是 2時N = N + 1,否則N = N + 2

      Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
      '↑令Ra這通用型變數用Union()函式 累積儲存格集,
      '規則是Ra自身 再加入 從"結果"工作表 N列第1欄儲存格到 該表N列第8欄儲存格,
      '這兩格之間的所有儲存格

      Brr(N, 2) = Arr(i, 1)
      '↑令N變數列第2欄Brr陣列值是 i迴圈列第1欄Arr陣列值 (明細科目)
      N = N + 1
      '↑令N這長整數變數X累加 1 (加1列)
      Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
      '↑同上
      For j = 1 To UBound(Arr, 2)
      '↑設內順迴圈!j從1到Arr陣列最大欄號數
         Brr(N, j) = Arr(1, j)
         '↑令N變數列第j迴圈欄Brr陣列值是 第1列第j迴圈欄Arr陣列值
      Next
   End If
   If InStr(St, "/" & Replace(Arr(i, 4), " ", "") & "/") <> 0 Then
   '↑同上
      GoTo Hi
      '↑就去找 Hi
   End If
   N = N + 1
   '↑同上
   Set Ra = Union(Ra, Range(Sh.Cells(N, 1), Sh.Cells(N, 8)))
   '↑同上
   For j = 1 To UBound(Arr, 2)
   '↑同上
      Brr(N, j) = Arr(i, j)
      '↑令N變數列第j迴圈欄Brr陣列值是 第i迴圈第j迴圈欄Arr陣列值
   Next
   Brr(N, 2) = "'" & Format(Brr(N, 2), "yyyy-mm-dd")
   '↑令N變數列第2欄Brr陣列值是"'" 符號連接自身日期轉為字串,
   '以"yyyy-mm-dd"方式呈現

   Brr(N, 3) = "'" & Brr(N, 3)
   '↑令N變數列第3欄Brr陣列值是"'" 符號連接自身
Hi:
'Hi在這裡
Next
Sh.UsedRange.ClearContents
'↑令Sh變數工作表有使用的儲存格最小方正區域儲存格內容清除
Sh.Cells.Borders.LineStyle = 0
'↑令Sh變數工作表全部的格線都不要
Ra.Borders.LineStyle = 1
'↑令Ra這儲存格集的格線是 細實線
Sh.[A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
'↑令Sh變數工作表從[A1]擴展縱向:Brr陣列縱向最大索引列號數,
'橫向:Brr陣列橫向最大索引欄號數,這範圍儲存格以 Brr陣列值倒入
'完工了

Set Y = Nothing
Set Z = Nothing
Set Arr = Nothing
Set Brr = Nothing
'工具容器要收一收,釋放掉變數
End Sub
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 5# Andy2483

Andy師兄,
萬分感謝你的幫忙和詳細的解讀, 謝謝你

TOP

回復 5# Andy2483
試試進階篩選
  1. Option Explicit
  2. Dim Rng(1 To 5) As Range
  3. Sub 項相分類重整()
  4.     設定
  5.     進階篩選
  6. End Sub
  7. Private Sub 設定()
  8.     Set Rng(1) = Sheets("分類帳").Range("A1").CurrentRegion
  9.     With Sheets("結果")
  10.         .Cells.Clear
  11.         Set Rng(2) = .[Z1]   '存放明細科目_幣別攔 不重復的項目
  12.         Set Rng(5) = .[A1]  '存放每次篩選的位置
  13.     End With
  14.     Rng(1).Range("A1").Copy Rng(2)
  15.     Rng(1).AdvancedFilter xlFilterCopy, Rng(2).Cells.Resize(2), Rng(2), True ' "明細科目_幣別"篩選不重復的項目
  16.     Set Rng(3) = Rng(2).Offset(, 1)                 '篩選的準則範圍
  17.      Rng(1).Range("A1,D1").Copy Rng(3)    '準則的欄位
  18.     Set Rng(4) = Rng(3).Offset(, 3)                 '指定被複製列的目標範圍
  19. End Sub
  20. Private Sub 進階篩選()
  21.     Dim i As Integer, R As Range
  22.     Rng(3).Range("B2") = "=" & """<>" & "    本 日 合 計"""                         '填[摘要]入準則 條件
  23.     i = 2
  24.     Do While Rng(2).Cells(i) <> ""
  25.         Rng(4).CurrentRegion.Clear
  26.         Rng(3).Range("A2") = Rng(2).Cells(i)                                                        '填入[明細科目_幣別]準則條件
  27.         Rng(1).AdvancedFilter xlFilterCopy, Rng(3).Resize(2, 2), Rng(4)      '進階篩選'
  28.         Rng(5) = Rng(2).Cells(i).Value                                                                     '標頭 篩選的[明細科目_幣別]
  29.         Rng(4).CurrentRegion.Offset(, 1).Copy Rng(5).Offset(1)                   '資料的範圍 .Offset(, 1) 向右移動一攔 **不需要 [明細科目_幣別]欄
  30.         Set Rng(5) = Rng(5).End(xlDown).Offset(2)
  31.         i = i + 1
  32.     Loop
  33. End Sub
複製代碼

TOP

        靜思自在 : 自己害自己,莫過於亂發脾氣。
返回列表 上一主題