luhpro

我放在 Open 裡, 你再自己改放到你要的 Sub 裡 :

1.   Dim lRow&, lRows&
   
2.   Dim sStr$
   
3.   Dim dTar
   
4.   Dim wsTar As Worksheet
   
5.    
   
6.   Set dTar = CreateObject("Scripting.Dictionary") ' 搜尋關鍵字
   
7.   
   
8.   For Each wsTar In Worksheets ' 遍歷所有工作表
   
9.     sStr = wsTar.Name ' 工作表名稱
   
10.     If Left(sStr, 1) = "T" Then
    
11.       Worksheets(sStr).Cells.ClearContents ' 清除 "T" 開頭的工作表內容
    
12.       dTar(sStr) = sStr ' 紀錄 "T" 開頭的工作表名稱,避免發生找不到工作表的錯誤
    
13.     End If
    
14.   Next
    
15.   
    
16.   With Worksheets("AA")
    
17.     lRows = .Cells(Rows.Count, 1).End(xlUp).Row ' 找最末列
    
18.     lRow = 1
    
19.    
    
20.     Do While lRow <= lRows
    
21.       sStr = "T" & .Cells(lRow, 1) ' 工作表名稱
    
22.       If dTar(sStr) <> "" Then ' 找到對應工作表
    
23.         .Cells(lRow, 1).CurrentRegion.Copy ' 區塊複製
    
24.         Worksheets(sStr).[A2].PasteSpecial Paste:=xlPasteValues ' 在對應工作表的 A2 貼上值
    
25.         lRow = lRow + .Cells(lRow, 1).CurrentRegion.Rows.Count - 1 ' 跳過已處理的區塊
    
26.       End If
    
27.       lRow = lRow + 1
    
28.     Loop
    
29.   End With

複製代碼

1015_ans.zip (22 Bytes)

下載次數: 4

2024-10-16 02:49