返回列表 上一主題 發帖

[發問] VBA 移動儲存格位置，另存新檔及刪除

luhpro

帖子
824 
主題
6 
精華
0 
積分
904 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2023-12-24 
1# 跳轉到 »
發表於 2020-12-11 23:55 | 顯示全部帖子
大家好，我第一次發帖，如果有什麼不對的請見諒
因為每月都要上交月結報表，不想再剪剪貼貼，所以在嘗試用 ...
lovenice831 發表於 2020-12-11 15:23


我把 Module2 刪掉,
並把所有的程式都集中在Module1了 :
  1.   Public iI% ' 整個檔案內都可共用的變數或物件使用Public宣告於此,
  2.   Public lRows&
  3.   Public wsTar As Worksheet, wsSou(1 To 2) As Worksheet ' 重複性作業利用物件陣列與迴圈完成

  5. Sub Auto_Open() ' 開啟活頁簿時會自動執行, 可放置會共用需先初始化的指令
  6.   Set wsTar = Worksheets("月結") ' 設定工作表物件變數
  7.   Set wsSou(1) = Worksheets("工作表1")
  8.   Set wsSou(2) = Worksheets("工作表2")
  9. End Sub

  11. Sub 月結_Click()
  12.   With wsTar
  13.     lRows = .Cells(Rows.Count, 1).End(xlUp).Row ' 從下往上找到最底下一列的列號
  14.     If lRows < 3 Then lRows = 3 ' 最小為3, 避免刪掉標題
  15.     .Range(.[A3], .Cells(lRows, 3)).Clear ' 清除上次產生的資料, 以便產生新資料
  16.   End With
  17.   
  18.   For iI = 1 To 2 ' 對兩個工作表逐個取出需要的資料做處理
  19.     With wsSou(iI)
  20.       .Select ' 底下作用儲存格移到A欄最新資料列前,需先將工作表Select
  21.       .[A3].AutoFilter Field:=2, Criteria1:="台灣"
  22.       .Range(.[A3], .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 3)).Copy wsTar.Cells(Rows.Count, 1).End(xlUp).Offset(1)
  23.          ' 拷貝需要的資料, 貼到月結工作表的資料最新列
  24.       .[A3].AutoFilter Field:=2
  25.       .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).Offset(1).Select ' 作用儲存格移到A欄最新資料列-A欄從下往上算最底下一列的下方那格
  26.     End With
  27.   Next
  28.   wsTar.Select ' 顯示月結工作表
  29. End Sub

  31. Sub test_()
  32.   Dim Vsha
  33.   Dim wsNew As Worksheet, wsTemp As Worksheet
  34.    
  35.     With Workbooks.Add
  36.       Set wsTemp = .ActiveSheet
  37.       wsTar.Copy before:=.Worksheets(1)
  38.       Set wsNew = .ActiveSheet
  39.       wsTemp.Delete
  40.       Set wsTemp = Nothing
  41.       With wsNew
  42.         .name = .[11]
  43.         For Each Vsha In .Shapes
  44.           Vsha.Delete
  45.         Next
  46.         .Parent.SaveAs ThisWorkbook.Path & Application.PathSeparator & .name
  47.       End With

  49.       .Close False
  50.     End With
  51. End Sub
複製代碼
test save&clear-a.zip (22.04 KB)

TOP

luhpro

帖子
824 
主題
6 
精華
0 
積分
904 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2023-12-24 
2#
發表於 2020-12-27 16:46 | 顯示全部帖子
回復  准提部林
謝謝幫忙，但我不知出現什麼問題，試著試著，現在全都用不到，麻煩幫忙查看一下，謝謝
...
lovenice831 發表於 2020-12-26 20:13

Monthly程式.jpg

.[c8].AutoFilter Field:=1, Criteria1:=xS.[j2]

試試看...

TOP

luhpro

帖子
824 
主題
6 
精華
0 
積分
904 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2023-12-24 
3#
發表於 2020-12-28 21:37 | 顯示全部帖子
本帖最後由 luhpro 於 2020-12-28 21:43 編輯
回復  准提部林

不好意思，我轉擋了並再上傳，麻煩了
lovenice831 發表於 2020-12-28 10:49

我覺得你的程式問題應該不在那裡喔.

以下是程式內容:
  1. Sub Monthly()
  2. Dim xS As Worksheet, T$, i&, xE As Range
  3. Call clean
  4. Set xS = Sheets("Monthly")
  5. If xS.[j2] = "" Then MsgBox "please choose!  ": Exit Sub
  6. For i = 1 To 3
  7.     With Sheets(1)
  8.          If .FilterMode Then .ShowAllData
  9.          .[c8].AutoFilter Field:=1, Criteria1:=xS.[j2]
  10.           Set xE = xS.Cells(Rows.Count, 1).End(xlUp)(5)
  11.          .AutoFilter.Range.Offset(1, 2).Resize(, 30).Copy xE
  12.          .ShowAllData
  13.          End With
  14. Next i
  15. End Sub
複製代碼
我想問題應該在於 :
.[c8].AutoFilter Field:=1, Criteria1:=xS.[j2] 後面的 Criteria1:=xS.[j2],
你的篩選鍵值都是相同的(因為xS的[j2]的值不會變,在程式中這格子內的值必須由User手動做變更)
當初就不太了解你3個迴圈怎麼都是抓相同的資料?

現在依你的敘述,
我想你改成這樣試試:
Dim xS As Worksheet, T$, i&, xE As Range, vPro()
vPro = Array("A", "B", "C")
......
For i =  0 To 2
......
.[c8].AutoFilter Field:=1, Criteria1:=vPro(i)

TOP

        靜思自在 : 人的眼睛長在前面，只看到別人的缺點，絲毫看不到自己的缺點。
返回列表 上一主題