[發問] 以C欄為索引,刪除不必要的列數,再另存新檔

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

2^#

發表於 2023-4-25 16:45 | 只看該作者

回復 1# PJChen

謝謝前輩發表此主題與範例
後學學習方案如下,請前輩參考

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, i&, j&, R, T, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("裝櫃通知")
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
If Not R Is Nothing Then R = R.Row
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
For i = 1 To UBound(Brr)
If Brr(i, 1) = "" Then
   For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
   If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
End If
Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
Set MyBook = ThisWorkbook
MyPath = MyBook.Path & "\"
If Dir(MyPath & Td, vbDirectory) = "" Then MkDir MyPath & Td
For Each T In Y.KEYS
If InStr(T, "|") Then GoTo i02
Sheets("裝櫃通知").Copy
Set xU = Cells(Rows.Count, 1).Resize(1, 8)
For i = 1 To UBound(Brr)
   If Brr(i, 1) <> T Then
      Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
   End If
Next
xU.Delete: [A7] = 1
Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
      FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
i02: Next
[A7].Resize(UBound(Brr), 8) = Brr
Set Y = Nothing: Set Sh = Nothing: Erase Brr
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

PJChen

　暱稱: PJ

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

3^#

發表於 2023-4-26 00:09 | 只看該作者

回復 2# Andy2483
您好,
測試結果,除了原先另存的檔案外,還會產生一個無廠商的空檔,可否幫忙看看~~感謝~~

-(XXX)CPOMPA1148GP-SOY402.rar (11.19 KB)

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

4^#

發表於 2023-4-26 08:00 | 只看該作者

回復 3# PJChen

謝謝前輩回復
後學以#1樓的範例植入程式碼執行後不會產生#3樓的檔案,請前輩再試試看或上傳植入程式的新原檔

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

PJChen

　暱稱: PJ

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

5^#

發表於 2023-4-26 20:03 | 只看該作者

回復 4# Andy2483

您好,
1..程式執行不太穩定,測試好多次,每次執行都有不同的結果,有時結果是正常的,但大部份不正常.
2..[G1]原有設定格式,將(數字)包在裡面,當它是數字時,EX:56表面上看起來是(56),實際是數字56,
這時執行程式會出錯,多了一個空檔-(65)CPOMPA1148GP-SOY402,當數字未出現時,會以(XXX)暫代,這時程式另存的檔案數量就正常.

3..資料區內,有設定自動換行,但另存新檔後,原本調整好的列高,會自動縮減
4..用(XXX)測試,又不正常,一樣會出現空檔,而且第6項,C欄中沒有代號,卻把它存在空檔中
5..檔案資料一直會有變化,所以需要測試很多種模式.
6..我將其中二次結果,檔案上傳,請幫忙查看程式

感謝！

65.rar (163.98 KB)

XXX.rar (164.35 KB)

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

6^#

發表於 2023-4-27 07:50 | 只看該作者

回復 5# PJChen

謝謝前輩回復,謝謝論壇
1.紅框處A欄的序號不是列序,而是項目序,所以需要要求前一個流程key in者要自律
1.1.不該填數字的就空格
1.2.該填入的正確數字要精確輸入

2.後方綠框處區域的空列有兩種方式
2.1.key in者要自律刪除這些空列
2.2.請前輩以下連結請研究一下,應用.EntireRow把不要的列刪除
https://learn.microsoft.com/zh-t ... loop-to-delete-cell

3.Q:資料區內,有設定自動換行,但另存新檔後,原本調整好的列高,會自動縮減
A:3.1.這是刪除局部儲存格,後方儲存格往上移動,移動後需要配合當列列高
A:3.2.簡單的方式:也是整列刪除,請前輩試試改看

祝成功

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

7^#

發表於 2023-4-27 10:16 | 只看該作者

謝謝論壇,謝謝各位前輩
後學今天複習#2樓的學習方案,方案心得註解如下,請各位前輩指教

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, R, T, i&, j&, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
'↑宣告變數:(Brr,Crr,V,Y,R,T)是通用型變數,(i,j)是長整數,(Td,Tn,G1)是字串變數
',(xR,xU)是儲存格變數,Sh是工作表變數,(MyBook,MyPath)是通用型變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是字典
Set Sh = Sheets("裝櫃通知")
'↑令Sh這儲存格變數是名為"裝櫃通知"的工作表
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
'↑令R這通用型變數是以Range.Find方法找D欄中儲存格值是全同 "TOTAL"字串
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.find
If Not R Is Nothing Then R = R.Row Else Exit Sub
'↑如果R變數找到儲存格!就令R這變數換裝R變數(儲存格)的列號,
'否則就結束程式執行
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
'↑令Brr這通用型變數是二維陣列,以[A7]到H欄(R變數-1)列儲存格值帶入
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1到 Brr陣列縱向最大索引列號
If Brr(i, 1) = "" Then
'↑如果i迴圈列第1欄Brr陣列值是空字元
   For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
   '↑設順迴圈!j從1到 8,令T這字串變數是自身連接,
   '(i迴圈列j迴圈欄Brr陣列值)去除頭尾空白字元後組成的新字串
   If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
   '↑如果T變數不是空字元!就令i迴圈列第1欄Brr陣列值是上一列陣列值
   '否則就跳到i01標示位置繼續執行
End If
Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
'↑令i迴圈列第1欄Brr陣列值當key,item是item自身累加1
If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
'↑如果令i迴圈列第1欄Brr陣列值當key查Y字典得item值是空字元?
'就令令i迴圈列第1欄Brr陣列值連接 "|c"後的新字串當key,item是i迴圈列第3欄Brr陣列值
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
'↑如果Y字典key的個數是 0個!就結束程式執行
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
'↑令G1這字串變數是 [G1]儲存格體現的字轉成文字連接[E1]儲存格值,連接"-",
'再連接([G2]儲存格去除"/"字元與"#"字元),最後連接[H2]儲存格值
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
'↑令Td這字串變數是現在時間轉成文字
Set MyBook = ThisWorkbook
'↑令MyBook這通用型變數是本活頁簿
MyPath = MyBook.Path & "\"
'↑令MyPath這通用型變數是本活頁簿路徑連接"\"後的新字串
MkDir MyPath & Td
'↑令產生一個資料夾,名字是 TD,路徑在MyPath
For Each T In Y.KEYS
'↑設逐項迴圈!令T變數是 Y字典裡的一個key
If InStr(T, "|") Then GoTo i02
'↑如果T變數裡有包含"|"字元!就跳到i02標示位置繼續執行
Sh.Copy
'↑令Sh變數("裝櫃通知"工作表)複製到新開的活頁簿
Set xU = Cells(Rows.Count, 1).Resize(1, 8)
'↑令xU這儲存格變數是本表A欄最後列儲存格,向右擴展8格範圍的儲存格
For i = 1 To UBound(Brr)
'↑令設順迴圈!i從1到 Brr陣列縱向最大索引列號
   If Brr(i, 1) <> T Then
   '↑如果i迴圈列第1欄Brr陣列值與變數不同?
      Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
      '↑令xU變數繼續以Union()方法納入不要的儲存格
   End If
Next
xU.Delete: [A7] = 1
'↑令xU變數(儲存格)刪除,令[A7]儲存格值是 1
Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
'↑令Tn這字串變數是組合各必要變數組成的新字串
ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
      FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'↑令檔案依指定位置指定檔名儲存
ActiveWindow.Close
'↑關閉檔案
i02: Next
Set Y = Nothing: Set Sh = Nothing: Erase Brr
'↑令釋放變數
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流