返回列表 上一主題 發帖

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

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

各位大大好,

裝櫃通知的 第6列為表頭,資料範圍為 第7列~D欄的TOTAL之間,資料會隨著需求,而增加or減少

我要以C欄為索引,刪除不必要的列數,並將資料範圍的A欄等差數列,全改為1,再另存新檔,新檔名= C欄為索引-原檔名
因為每次另存新檔,內容只會有一個廠商名稱,所以item只能是1
但原檔資料不能變更,所有的儲存格也不要有任何改變(內有一些公式)

EX1:第一次 C7為CHL,則刪除列8:22,另存新檔名為 CHL-(56)CPOMPA1148GP-SOY402
EX2:第二次 C8為REL,則刪除列7 & 9:22,另存新檔名為 REL-(56)CPOMPA1148GP-SOY402
EX3:最後一次 C21為LT,則刪除列7:20 & 22,另存新檔名為 LT-(56)CPOMPA1148GP-SOY402

請問要如何達成這個需求?
(56)CPOMPA1148GP-SOY402 裝櫃通知.rar (11.95 KB)

回復 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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

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

TOP

回復 3# PJChen


    謝謝前輩回復
後學以#1樓的範例植入程式碼執行後不會產生#3樓的檔案,請前輩再試試看或上傳植入程式的新原檔
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 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)

TOP

回復 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.簡單的方式:也是整列刪除,請前輩試試改看

祝 成功

20230427_1.jpg
2023-4-27 07:50
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

謝謝論壇,謝謝各位前輩
後學今天複習#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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

A欄序號空白, 但H欄備註有內容, 算上一個序號的, 要一起複製???
發帖最好要做幾個需求結果例子, 光憑一堆文字說明看著累~~

TOP

執行程式前, 要自己先檢查一下資料, 將資料補齊, 並把不要的行先刪除,
不要又來問程式有問題~~程式只負責處理正確的資料

Test(裝櫃通知)-1.rar (18.41 KB)

TOP

回復 9# 准提部林
准大好,

同一儲存格部份改變顏色的字,另存新檔後,會變成黑色,
請問要怎麼保持原格式?

我將測試有問題的檔PO上,請幫忙看下~~ 另存新檔測試.rar (53.05 KB)

TOP

        靜思自在 : 難行能行,難捨能捨,難為能為,才能昇華自我的人格。
返回列表 上一主題