VBA_依條件篩選資料

這個代碼用在人工在A表格篩選完資料(標色)，然後將篩選完的資料，選取某些欄位將相關資料會到另一個表格中。 

Sub A1_發票樣本()

'2021/12/24 

Application.ScreenUpdating = False

'sh_原則人工篩選 量及單號數較多的

Dim sh_清單 As Worksheet, sh_樣本 As Worksheet

Dim D_欄位, D_資料

Set sh_清單 = Sheets("商業發票表頭") '須先由大至小排序

Set sh_樣本 = Sheets("傳票用") '可以設定自動檢查

Set D_欄位 = CreateObject("scripting.dictionary")

Set D_資料 = CreateObject("scripting.dictionary")

With sh_清單

lc = .Range("A1").End(xlToRight).Column

lr = .Range("A1048576").End(xlUp).Row

For c = 1 To lc

D_欄位(.Cells(1, c).Text) = c

Next

For i = 2 To lr

If .Cells(i, 1).Interior.ColorIndex <> xlNone Then

in_廠商 = .Cells(i, D_欄位("協力廠商"))

in_發票日 = .Cells(i, D_欄位("商業發票日期"))

in_發票號碼 = .Cells(i, D_欄位("商業發票號碼"))

in_幣別 = .Cells(i, D_欄位("付款幣別"))

' in_條件 = .Cells(i, D_欄位("付款條件"))

in_付款 = .Cells(i, D_欄位("付款群組"))

in_序號 = .Cells(i, D_欄位("內部序號"))

in_金額 = .Cells(i, D_欄位("商業發票金額"))

D_資料(i) = Array(in_廠商, in_發票日, in_發票號碼, in_幣別, in_付款, in_序號, in_金額)

End If

Next

End With

With sh_樣本

.Cells.Delete

arr_標題 = Array("廠商", "發票日", "發票號碼", "幣別", "付款方式", "請款單序號", "發票金額")

.Range("A1").Resize(, UBound(arr_標題) + 1) = arr_標題

.Range("A2").Resize(D_資料.Count, UBound(arr_標題) + 1) = Application.Transpose(Application.Transpose(D_資料.items))

End With

End Sub

Excel_SQL_Switch使用

以前使用過Switch方式處理資料，去年底以來一直使用Power Query，對於SQL的語法有點生疏，還好還是試出來了。 

select *,int((離職日-到職日)/365) as 年資,

switch(

[CF_DEPT_CABBR] like "%AC%","AC課"

,[CF_DEPT_CABBR] like "%RAD%","RAD課"

,[CF_DEPT_CABBR] like "%工程%","工程課"

,[CF_DEPT_CABBR] like "%線外%","線外加工課"

,[CF_DEPT_CABBR] like "%資材%","資材部"

,[CF_DEPT_CABBR] like "%擠%","擠型課"

,[CF_DEPT_CABBR] like "%生技%","生技課"

,[CF_DEPT_CABBR] like "%會計%","財務會計處"

,[CF_DEPT_CABBR] like "%財務%","財務會計處"

,[CF_DEPT_CABBR] like "%管理課%","管理課"

,[CF_DEPT_CABBR] like "%物流課%","物流課"

,true,[CF_DEPT_CABBR]) as 部門 from ['離職名單2020-2021$'] where 到職日 is not null

SQL_計算年資(不聰明的方式)

Excel環境的SQL無法使用更新方式的方式，譬如today 或是 date的方式，也許可以，但目前還沒找到，因此用了下面不聰明的方式處理 DATEDIFF("yyyy",時間,DATE())

select *,#2021/12/29# As 今天,int((今天-[ENTR_DATE])/365) as 年資,switch(

[DEPT_CNAME] like "%AC%","AC課"

,[DEPT_CNAME] like "%RAD%","RAD課"

,[DEPT_CNAME] like "%工程%","工程課"

,[DEPT_CNAME] like "%線外%","線外加工課"

,[DEPT_CNAME] like "%資材%","資材部"

,[DEPT_CNAME] like "%擠%","擠型課"

,[DEPT_CNAME] like "%生技%","生技課"

,[DEPT_CNAME] like "%會計%","財務會計處"

,[DEPT_CNAME] like "%管理課%","管理課"

,true,[DEPT_CNAME]) as 部門 from [在職名單1228$]

SQL_基本語法(使用環境_Excel)

     新環境沒有的Office沒有達到Power Query的最低配置office 2016，只能把以前的方法拿出來用，VBA+SQL，現在開始記錄一下各種寫法

select * from ['Select_accounts$'] where 業務 not like "%二%" and 業務 not like "%一%" 

select distinct 部門代碼 from [fnd_gf\m_15542471$] where 來源 like "M%" and 部門代碼 not in ('1184','1488','1531','1568','1698','43')

中油PAY實際使用狀況

         最近實際使用中油PAY的確是省了挺多，11/27~12/25共省了740(還有一張50元油券還未使用)，下面有一個表是實際抵用狀況以及中油pay優惠整理，實際上與目前DM的9.4%不太依樣，最高應該是9.1%。

        因為開車加油支出稍高，因此中油PAY還是有省了一些，如果要盡可能的達到9.1%(不可能)，只能盡量自助，但是有一些優惠的使用必須靠人工加油時抵用(如果讓人工加油剛好接近抵用數，可能就會很接近9.1%)。

         第一個月的優惠%數換算約8.56%，總共支出6,301+(740-150)=6,891，總共抵740-150，換算後8.56%。(因為12/25的200元是刷卡禮，不能算是原本他的遊戲規則，我是因為盡量降低人工加油金額，所以先選抵用200元，實際有一張50元是儲值送的。)

我的方式:

1.盡可能自助。(每公升0.8元約2.7%比人工產生的會員點數1.5%多)

2.星期一儲值3000，50元油票約1.6%。 還會有4%紅利金。

3.人工加油時盡可能接近可以抵的 會員點數+中信紅利點數+油票。(我還沒做到極致)

4.目前中信紅利點數星期六抵時會由每100點可以抵8元變100點抵10元。

其他備註:

1. .中信紅利金(儲值給的2%、4%)，在自助時就能自動扣。
2. 中油點數、中信紅利點數(刷卡的部分，包含用中信卡儲值)、油券只能透過人工加油時使用。

中油APY整理

中油APY實際使用

Word_草稿模式調整欄位大小

 我想我的Word應該也會稍微變強吧從這個月開始...

今天編輯辦法修正對照表時，最後一欄跑掉，用大綱模式無法將最後一欄調整，切換到草稿模式反而可以。

Power Query冷知識

1.  高版本的exel(如365版)製作的Power  Query如果在低版本excel(如2007版)中不能看到Power Query，於低版本改過excel後存檔再回到高版本中打開，原本編輯的PQ仍然存在。(365版製作的PQ於2007版excel中修改過工作表存檔，於365開啟時仍能看到PQ查詢表)-2021/12/18

VBA_彙整多期BS及IS資料

彙整多期BS及IS資料

 Sub A0_BS多年度科目比較()

'2021/12/15 

Application.ScreenUpdating = False

Dim sh_本期 As Worksheet, sh_前期 As Worksheet, sh_目地 As Worksheet, D_工作表, D_資料

Set D_工作表 = CreateObject("scripting.dictionary")

Set D_資料 = CreateObject("scripting.dictionary")

Set D_科目 = CreateObject("scripting.dictionary")

'----------------------------------------------------------------------

arr_sh = Array("202101", "202102", "202103", "202104", "202105", "202106", "202107", "202108", "202109")

For i = 1 To Sheets.Count

D_工作表(Sheets(i).Name) = Sheets(i).Name

Next

If D_工作表.exists("彙整") = False Then

Sheets.Add.Name = "彙整"

End If

Set sh_目地 = Sheets("彙整")

For i_sh = LBound(arr_sh) To UBound(arr_sh)

With Sheets(arr_sh(i_sh))

lr = .Range("A1048576").End(xlUp).Row

in_月份 = arr_sh(i_sh)

For i = 6 To lr

If .Cells(i, "B") <> "" And .Cells(i, "B") <> 0 Then

in_科目A = .Cells(i, "A")

in_餘額A = .Cells(i, "B")

D_科目(in_科目A) = in_科目A

in_條件A = in_月份 & in_科目A

D_資料(in_條件A) = in_餘額A

End If

Next

For i = 6 To lr

If .Cells(i, "E") <> "" And .Cells(i, "E") <> 0 Then

in_科目B = .Cells(i, "D")

in_餘額B = .Cells(i, "E")

D_科目(in_科目B) = in_科目B

in_條件B = in_月份 & in_科目B

D_資料(in_條件B) = in_餘額B

End If

Next

End With

Next

With sh_目地

.Cells.Delete

.Range("B1").Resize(, UBound(arr_sh) + 1) = arr_sh

.Range("A2").Resize(D_科目.Count, 1) = Application.Transpose(D_科目.keys)

For c = 2 To UBound(arr_sh) + 2

in_月份 = .Cells(1, c)

For i = 2 To D_科目.Count + 2

in_科目 = .Cells(i, 1)

in_條件 = in_月份 & in_科目

.Cells(i, c) = D_資料(in_條件)

Next

Next

End With

D_資料.RemoveAll

D_科目.RemoveAll

End Sub

Sub A0_IS多年度科目比較()

'2021/12/15 

Application.ScreenUpdating = False

Dim sh_本期 As Worksheet, sh_前期 As Worksheet, sh_目地 As Worksheet, D_工作表, D_資料

Set D_工作表 = CreateObject("scripting.dictionary")

Set D_資料 = CreateObject("scripting.dictionary")

Set D_科目 = CreateObject("scripting.dictionary")

'----------------------------------------------------------------------

arr_sh = Array("202101", "202102", "202103", "202104", "202105", "202106", "202107", "202108", "202109")

For i = 1 To Sheets.Count

D_工作表(Sheets(i).Name) = Sheets(i).Name

Next

If D_工作表.exists("彙整") = False Then

Sheets.Add.Name = "彙整"

End If

Set sh_目地 = Sheets("彙整")

For i_sh = LBound(arr_sh) To UBound(arr_sh)

With Sheets(arr_sh(i_sh))

lr = .Range("A1048576").End(xlUp).Row

in_月份 = arr_sh(i_sh)

For i = 5 To lr

If .Cells(i, "B") <> "" And .Cells(i, "B") <> 0 Then

in_科目A = .Cells(i, "A")

in_餘額A = .Cells(i, "B")

D_科目(in_科目A) = in_科目A

in_條件A = in_月份 & in_科目A

D_資料(in_條件A) = in_餘額A

End If

Next

End With

Next

With sh_目地

.Cells.Delete

.Range("B1").Resize(, UBound(arr_sh) + 1) = arr_sh

.Range("A2").Resize(D_科目.Count, 1) = Application.Transpose(D_科目.keys)

For c = 2 To UBound(arr_sh) + 2

in_月份 = .Cells(1, c)

For i = 2 To D_科目.Count + 2

in_科目 = .Cells(i, 1)

in_條件 = in_月份 & in_科目

.Cells(i, c) = D_資料(in_條件)

Next

Next

End With

D_資料.RemoveAll

D_科目.RemoveAll

End Sub

VBA_兩年度前十進銷貨彙整

兩年度前十進貨及銷貨比較用

 Sub A0_前十進()

'2021/12/16 

Application.ScreenUpdating = False

Dim sh_本期 As Worksheet, sh_目地 As Worksheet, D_工作表, D_資料, D_對象

Set D_工作表 = CreateObject("scripting.dictionary")

Set D_資料 = CreateObject("scripting.dictionary")

Set D_對象 = CreateObject("scripting.dictionary")

'----------------------------------------------------------------------

arr_sh = Array("2021", "2020")

For i = 1 To Sheets.Count

D_工作表(Sheets(i).Name) = Sheets(i).Name

Next

If D_工作表.exists("彙整") = False Then

Sheets.Add.Name = "彙整"

End If

Set sh_目地 = Sheets("彙整")

For i_sh = LBound(arr_sh) To UBound(arr_sh)

With Sheets(arr_sh(i_sh))

lr = .Range("A65536").End(xlUp).Row

in_年度 = arr_sh(i_sh)

For i = 3 To lr

in_科目 = .Cells(i, "B")

in_對象 = .Cells(i, "C")

in_金額 = .Cells(i, "D")

in_趴數 = .Cells(i, "E")

in_品項 = .Cells(i, "F")

D_對象(in_對象) = Array(in_科目, in_對象)

in_條件A = in_年度 & in_對象

D_資料(in_條件A) = Array(in_金額, in_趴數, in_品項)

Next

End With

Next

With sh_目地

.Cells.Delete

.Range("A2").Resize(D_對象.Count, 2) = Application.Transpose(Application.Transpose(D_對象.items)) '有三個資料

.Range("C1").Resize(, 6) = Array("2021", "2020", "2021", "2020", "2021", "2020")

in_年度數 = UBound(arr_sh) + 1

For i = 2 To D_對象.Count + 2

For ic = 0 To 2 '配合字典******************

For c = 3 + ic * in_年度數 To UBound(arr_sh) + 3 + ic * in_年度數 '這裡要注意起始點

'For c = 3 + ic * 2 To UBound(arr_sh) + 3 + ic * 2 '這裡要注意起始點

in_年度 = .Cells(1, c)

in_對象 = .Cells(i, 2)

in_條件 = in_年度 & in_對象

If D_資料.exists(in_條件) = True Then '字典中使用陣列所以必須使用存在檢查******************

.Cells(i, c) = D_資料(in_條件)(ic)

End If

Next

Next

Next

'最後執行攔未修改

.Range("A1").Resize(, 8) = Array("科目代碼", "供應商", "2021金額", "2020金額", "2021比例", "2020比例", "2021項目", "2020項目")

End With

D_資料.RemoveAll

D_對象.RemoveAll

End Sub

Sub A0_前十銷()

'2021/12/16Application.ScreenUpdating = False

Dim sh_本期 As Worksheet, sh_目地 As Worksheet, D_工作表, D_資料, D_對象

Set D_工作表 = CreateObject("scripting.dictionary")

Set D_資料 = CreateObject("scripting.dictionary")

Set D_對象 = CreateObject("scripting.dictionary")

'----------------------------------------------------------------------

arr_sh = Array("2021", "2020")

For i = 1 To Sheets.Count

D_工作表(Sheets(i).Name) = Sheets(i).Name

Next

If D_工作表.exists("彙整") = False Then

Sheets.Add.Name = "彙整"

End If

Set sh_目地 = Sheets("彙整")

For i_sh = LBound(arr_sh) To UBound(arr_sh)

With Sheets(arr_sh(i_sh))

lr = .Range("A65536").End(xlUp).Row

in_年度 = arr_sh(i_sh)

For i = 3 To lr

in_科目 = .Cells(i, "B")

in_對象 = .Cells(i, "C")

in_金額 = .Cells(i, "D")

in_趴數 = .Cells(i, "E")

in_條件 = .Cells(i, "F")

in_品項 = .Cells(i, "G")

D_對象(in_對象) = Array(in_科目, in_對象)

in_條件A = in_年度 & in_對象

D_資料(in_條件A) = Array(in_金額, in_趴數, in_條件, in_品項)

Next

End With

Next

With sh_目地

.Cells.Delete

.Range("A2").Resize(D_對象.Count, 2) = Application.Transpose(Application.Transpose(D_對象.items)) '有三個資料

.Range("C1").Resize(, 8) = Array("2021", "2020", "2021", "2020", "2021", "2020", "2021", "2020")

in_年度數 = UBound(arr_sh) + 1

For i = 2 To D_對象.Count + 2

For ic = 0 To 3 '配合字典******************

For c = 3 + ic * in_年度數 To UBound(arr_sh) + 3 + ic * in_年度數 '這裡要注意起始點

in_年度 = .Cells(1, c)

in_對象 = .Cells(i, 2)

in_條件 = in_年度 & in_對象

If D_資料.exists(in_條件) = True Then '字典中使用陣列所以必須使用存在檢查******************

.Cells(i, c) = D_資料(in_條件)(ic)

End If

Next

Next

Next

'最後執行攔未修改

.Range("A1").Resize(, 10) = Array("科目代碼", "供應商", "2021金額", "2020金額", "2021比例", "2020比例", "2021條件", "2020條件", "2021項目", "2020項目")

End With

D_資料.RemoveAll

D_對象.RemoveAll

End Sub

VBA_針對儲存格特殊字眼標示

下面的代碼用來標示可能存在的辦法，不過要先把辦法的檔案名稱弄到excel中可以參考 這個 VBA_建立檔案目錄 ，如果有項辦法這種原本有紀錄清單的，就。 

Sub A1_關鍵字確認_辦法()

    '2021/12/10 

    Application.ScreenUpdating = False

    

    arr_辦法 = Array("制度", "辦法", "循環", "守則", "準則", "規則", "作業", "程序", "規範", "文管", "衍生", "條文", "對照", _

  "第1版", "第2版", "第3版", "第4版", "第5版", "第6版", "第-1版", "第-2版", "第-3版", "第-4版", "第-5版", "第一版", "第二版", "第三版", "第四版", "第五版","章程","財務及非財務","資通")

    

    With ActiveSheet

        lr = .Range("A1048576").End(xlUp).Row

        For i = 2 To lr

            For i_arr = LBound(arr_辦法) To UBound(arr_辦法)

                If .Cells(i, 1) Like "*" & arr_辦法(i_arr) & "*" Then

                    .Cells(i, 1).Interior.ColorIndex = 6

                    Exit For

                End If

            Next

        Next

    End With

End Sub

VBA_建立檔案目錄

使用VBA抓取檔案路徑中的清單，用在交接把自己手上檔案移交給人時很好用，當然你從人家手上接到檔案，如果沒清單時也很好用。

Sub A0_檔案清單_DIC()

Application.ScreenUpdating = False

' 比ARR慢一點點

t = Timer

Dim DIC

Set DIC = CreateObject("scripting.dictionary")

Range("A:L").ClearContents

'n = 0

Range("A1").Resize(, 8) = Array("檔名", "路徑", "大小", "修改時間", "建立時間", "授權時間", "資料夾", "檔案格式")

Dim strPath As String

strPath = "D:\稽核工作" '修改這裡

Dim OBJ As Object, Folder As Object, File As Object

Set OBJ = CreateObject("Scripting.FileSystemObject")

Set Folder = OBJ.GetFolder(strPath)

Call ListDIC(Folder, DIC)

Dim SubFolder As Object

For Each SubFolder In Folder.SubFolders '子資料夾

    Call ListDIC(SubFolder, DIC)

    Call GetSubFolders(SubFolder, DIC)

Next SubFolder

Range("A2").Resize(DIC.Count, 8) = Application.Transpose(Application.Transpose(DIC.Items))

MsgBox Timer - t

DIC.RemoveAll

End Sub

'---------------------------------------------------------------------------------------------------------

Sub ListDIC(ByRef Folder As Object, DIC)

For Each File In Folder.Files'擷取的內容

        DIC(File.Path) = Array(File.Name, File.Path, (File.Size / 1024), File.DateLastModified, _

            File.DateCreated, File.DateLastAccessed, Split(File.ShortPath, "\" & File.Name)(0), File.Type)

Next File

End Sub

'------------------------------------------------------------------------

Sub GetSubFolders(ByRef SubFolder As Object, DIC)

Dim FolderItem As Object '資料夾

For Each FolderItem In SubFolder.SubFolders

    Call ListDIC(FolderItem, DIC)

    Call GetSubFolders(FolderItem, DIC)   '這個方式沒使用過

Next FolderItem

End Sub

車子真的只有小問題嗎?

12/4 防盜器再響，看來不是六角鎖問題，難道是中控?? 

11/30 去保養廠換副駕駛的六角鎖，當初事故擠壓到副駕駛車門，但副駕駛的六角鎖看起來是舊品，因為跟其他三個門明顯不一樣，而且感覺有點鬆，感覺是這個造成防盜器響，跟外面的保養廠討論後換了六角鎖1800。這問題跟原廠反應時，得到的回應是日子有點久了，可以明顯的感覺到他們不想再處理。

11/21最近假日有聽到防盜器響，每次都是在下午，也有在上班時間發生，因為都是在12:00~16:00之間所以懷疑跟溫度有關，可能是造成門邊的感應到以為沒關好之類。(原廠說防盜晶片可能壞掉，價格大約9000-1萬，可能也沒貨....)

2/11去拿車時，原廠的理賠部門說可能還會有小問題，不過問題是不是真的小就不知...，回我家時拿東西時順便開引擎蓋看發現漏油，開回去說動力的油管硬化，當天換沒另外收。

2/12 原本要去紫南宮，結果引擎故障燈亮了，於是取消行程，怕有其他問題

2/17 開工首日請半天去處理，當下說如果再亮就是含氧感知器問題，因為不是事故造成所以到時候換要錢。後來開回家又亮，問了外面保養廠還有查網路說原廠的零件比較不會有問題，那個問題也沒危險，但看燈亮就礙眼，於是約了2/20換零件。

2/20 換含氧感知器，當下有說理賠要當初說要幫我處理搖臂蓋墊片，要等零件再約(難怪還有看漏油現象，原來是那邊造成...)。

2/22 上班路途又亮。

2/24 打去問零件來沒順便抱怨故障燈又亮(說那時電腦帶出去所以沒用電腦消故障碼，搖臂蓋墊片零件來一起處理)。

2/27 原廠理賠打來說零件來了，說隔週星期二還是星期三請人到我公司來開去修。

3/2(原本要來忘記) 3/3搖臂蓋來了(ABS亮燈順便換電池<貴>

3/8開去看是哪漏油約好3/12要來(原本要來沒來)

 3/15 換零件(另一個漏油) 

3/16早上開引擎蓋發現搖臂蓋沒索回去(連絡說要來公司鎖) ,這個挺扯的，是師傅做的，竟然沒鎖。

3/19幫忙看d檔燈，後來是將儀表板燈換到D檔，說一個200多元他們沒零件，有報廢車換下來再幫我換，他們會再記得嗎??

5/14 回外面保養廠保養時，師傅說原廠板金可能拉得不夠水箱跟引擎腳咬太緊。起步時有怪聲音可能哪裡沒鎖緊。

5/18 原廠來公司開走，起步怪聲音好了也比較順。板金需要重新約時間處理。

5/21 原廠把車開去將水箱板金重弄，快下班時打趣問原廠說要隔天才好，5/22(六)將車開回。