亞瑟的升級過程

  以下是我請AI做的動作，AI整理我要的動作如下，問了ChatGPT、gemini、Grok，之前詢問過的簡單版前身，是gemini勝出，這次Grok勝出，但Gpt修改錯誤後，也可以運行。 廢品轉換的問題資料 廢品轉換的結果 ✅ 第一個動作： 找出料號為「3開頭」的第一筆出庫（數量為負數）資料。 根據該出庫的「單號」，列出料號為「1開頭」的轉換庫存資料（相同單號）。 ✅ 第二個動作： 針對每一筆第一動作中出現於 J欄的料號 ，找出該料號在該日期以後的**第一筆出庫（負數）**紀錄，並記錄下來。 Sub 出庫轉換追蹤_GPT版()     Dim wsA As Worksheet, wsB As Worksheet     Dim lastRowA As Long, outRow As Long     Dim dictFirstOut As Object, dictTransfer As Object, dictSecondOut As Object     Dim i As Long, key As String     Dim partNo As String, qty As Double, docDate As Date, docNo As String     Dim item As Variant     Dim cellData As Variant     Set wsA = ThisWorkbook.Sheets("A")     Set wsB = ThisWorkbook.Sheets("B")     wsB.Cells.ClearContents          lastRowA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row     outRow = 2 '從第2列開始輸出     Set dictFirstOut = CreateObject("Scripting.Dictio...

  針對資料夾內所有子資料夾所有照片及影片檔案都移到最上層資料夾用VBA寫一個針對相片及影片的建立日、修改日、存取日判斷，以這三個日期中最小的日期依年月資料夾分類，如果該資料夾不存在就新建，當檔案名稱如果重複時就自動在檔案名稱依序給予 _+流水號 分類結果4436個影片及照片自動移到最上層資料夾，只花不到1分鐘 分類結果 同一時間處理完畢 Sub OrganizePhotosAndVideosByDate()     Dim topFolderPath As String     Dim fso As Object     Dim topFolder As Object     Dim subFolder As Object     Dim file As Object     Dim earliestDate As Date     Dim yearMonth As String     Dim targetFolder As String     Dim fileExtensions As Variant     Dim i As Integer     Dim fileName As String     Dim newFileName As String     Dim counter As Integer     ' 設置要處理的頂層資料夾路徑     topFolderPath = "C:\Your\Path\To\PhotosAndVideos" ' 替換為實際的路徑          ' 要處理的文件副檔名     fileExtensions = Array("jpg", "jpeg", "png", "gif", "bmp", "mp4", "avi", "mov", "wmv", "mkv")          ' 創建 ...

  A工作表的B欄是收件人的mail位址，不同收件人以,分隔， C欄顯示mail位置，D欄顯示mail出現次數，E欄顯示抓取@之後的內容。 VBA代碼如下: Sub CountRecipients()     Dim ws As Worksheet     Dim lastRow As Long     Dim recipients As String     Dim recipientList() As String     Dim recipient As Variant     Dim dict As Object          Set ws = ThisWorkbook.Sheets("A") ' 將 "A" 替換為你的工作表名稱          lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row          Set dict = CreateObject("Scripting.Dictionary")          ' 遍歷B欄中的每個儲存格，將收件人位址以逗號分隔的方式拆分並統計數量     For i = 1 To lastRow         recipients = ws.Cells(i, "B").Value         recipientList = Split(recipients, ",")         For Each recipient In recipientList             recipient = Trim(recipient)             If r...

  針對儲純格中( )內字眼標示顏色，如果同一個儲存格純在兩個()，也會都標示顏色。 Sub ChangeColor()     Dim cell As Range     Dim i As Integer, j As Integer     For Each cell In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)         If cell.Value <> "" Then             i = InStr(1, cell.Value, "(")             j = InStr(1, cell.Value, ")")             If i > 0 And j > 0 And i < j Then                 cell.Characters(i, j - i + 1).Font.ColorIndex = 5 '修改括號內字元的顏色                 If InStr(j + 1, cell.Value, "(") > 0 Then '判斷是否存在第2個以上的括號                     k = InStr(j + 1, cell.Value, "(")                     l = InStr(j + 1, cell.Value, ")")            ...

                 在工作上看過很多人習慣用表格呈現資料，不過不是以樞紐表，而是用輸入的方式，這在分析運用上很沒彈性，剛好有一個表格要資料化，本來想用Power Query處理，後來還是決定寫VBA，避免Power Query會一直重複查詢，而且很多人喜歡把不同部門資料放在同一個工作表內，這時還是用VBA比較快。              在家裡弄了個簡單版，隔天上工可以快速修改用上。 Sub A0_反樞紐()     '2022/11/24 22:35     Dim arr_資料()     With ActiveSheet         br = 3         lr = .Cells(br, 1).End(xlDown).Row         lc = .Cells(br, 1).End(xlToRight).Column         n = 0         For i = br To lr             in_代碼 = .Cells(i, 1)             in_名稱 = .Cells(i, 2)             For c = 1 To 16 '12個月+4季                 in_月份 = .Cells(1, c * 2 + 1)                 in_噸數 = .Cells(i, c * 2 + ...

       幾年前在前公司，某一天正在key VBA代碼時，突然不用查代碼可以一直很順的打出代碼， 那時我相信武俠小說寫的頓悟 ，今天晚上洗澡時在想明天公司資料擷取時要怎麼寫代碼比較快(不好的習慣，下班後還在想公事...太難改掉)，因為是以前寫過的，洗著洗著突然認為可以在沒資料時寫出代碼，就這樣試著打，還真的完成代碼了，明天去公司只要微調就能使用，這次有BLOG記錄這個心情，心情開心，這跟超級賽亞人變身一樣嗎?            我想曾經打過的方式，應該都能在沒資料時都把code建構出來了吧。 PS.下面的代碼用在抓樞紐資料，因為樞紐跑出來會有點類似縮排，如果要抓類似資料格式，我個人認為是用VBA比較快。(尤其是沒有可用Power Query版本的office) Sub A0_頓悟()     '2022/1/13 22:03          Application.ScreenUpdating = False     Dim D_資料, sh_來源 As Worksheet, sh_目的 As Worksheet          Set D_資料 = CreateObject("scripting.dictionary")     Set sh_來源 = Sheets("A")     Set sh_目的 = Sheets("B")          With sh_來源         lr = .Range("A1048576").End(xlUp).Row         arr_資料 = .Cells(1, 1).Resize(lr, 2)                  For i_次 = 1 To 2      ...

             移動檔案用清單的方式，這是我覺得比較方便的方式，試了之後很快，下面可以看到來源夾剩一個檔案，故意留下來看看是不是我要的結果，目標夾全移過去了。            為了整理凌亂的檔案，這是其中一個步驟。 移動檔案的清單 移動檔案的來源夾 移動檔案的目標夾  Sub 移動檔案_清單方式() '2022/1/12 22:15     Application.ScreenUpdating = False     With ActiveSheet     For i = 2 To 8     in_原始 = .Cells(i, 1).Text     in_新位置 = .Cells(i, 2).Text         Name in_原始 As in_新位置     Next     End With End Sub

移動檔案，整個資料夾移動，  Sub 移動檔案_資料夾() '2022/1/12  21:56 Application.ScreenUpdating = False Dim objFile As File Dim objFolder As Folder Dim objFSO As FileSystemObject Dim in_原始夾 As String Dim in_目標夾 As String in_原始夾 = "C:\Users\arthur\Desktop\C槽桌面\TESTA" in_目標夾 = "C:\Users\arthur\Desktop\C槽桌面\TEST" Set objFSO = New FileSystemObject Set objFolder = objFSO.GetFolder(in_原始夾) For Each objFile In objFolder.Files 'If (objFile.Name <> ThisWorkbook.Name) And (InStr(1, objFile.Name, ".xls") Or InStr(1, objFile.Name, ".csv")) Then objFile.Move (in_目標夾 & "\" & objFile.Name) 'End If Next objFile End Sub

下面的代碼是當初整理相片時網路上找到然後修改，印象中花瞭半小時處理1萬個以上的相片檔，現在想要用在批次整理新公司的檔案，不過還不夠簡單，但先存一下做個紀錄。  主要功能，透過檢查日期的方式，以檔案的修改日、建立日、授權日中最小的日期當作檔案一開始的日期( 如果同一天會做備份，這部分需要自己檢查有沒有依樣 )，然後做分類，算是比較花時間的方式，但比自己去分類相片簡單多了。 Sub 移動檔案___改()     '2017/10/14 2017/10/16改     Application.ScreenUpdating = False          Dim objFile As File, 目的_File As File     Dim objFolder As Folder, 目的_folder As Folder     Dim D_檔案檢查 As Object               ' DateLastModified DateCreated DateLastAccessed     Dim objFSO As FileSystemObject          Dim current_path ' As String 在namespace那邊抓不到               current_path = "D:\照片\2016\新增資料夾" '應該可以用dic 方式把所有資料夾丟到Arr or 參考取得檔案名稱的方式修改          Set objFSO = New FileSystemObject     Set objFolder = objFSO.GetFolder(current_path)     Set D_檔案檢查 = CreateObject("scripting.diction...

如果使用Power Query 該有的欄位都有，但不同檔的欄位排列不一樣的話(A檔 甲乙丙,B檔 丙乙甲)，Power Query可以自動排列，我還是比較喜歡用Power Query。 彙總個工作表資料  Sub A0_彙整資料()     '2022/1/2 22:00  22:30完成     Application.ScreenUpdating = False          Dim D_項目, D_附件, D_工作表, Sh_項目 As Worksheet, sh_附件 As Worksheet          Set D_項目 = CreateObject("scripting.dictionary")     Set D_附件 = CreateObject("scripting.dictionary")     Set D_工作表 = CreateObject("scripting.dictionary")               For i = 1 To Sheets.Count         D_工作表(Sheets(i).Name) = i     Next     If D_工作表.exists("項目彙總") = False Then         Sheets.Add.Name = "項目彙總"     End If     If D_工作表.exists("附件彙總") = False Then         Sheets.Add.Name = "附件彙總"     End If     Set Sh_項目 = Sheets("項目彙總")     Set sh_附件 = Sheets("附件彙總"...

這個代碼用在人工在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_欄位("商業發票號碼")) ...

彙整多期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)) ...