返回列表 上一主題 發帖

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

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

大家好,我第一次發帖,如果有什麼不對的請見諒
因為每月都要上交月結報表,不想再剪剪貼貼,所以在嘗試用兩個按鈕解決它們 ^^"
問題
1) 我只能做到剪貼第一個工作頁,貼上後怎樣試都不能令儲存格自動跳到下一列的空格上,令到貼上第二個工作表的資料時都把第一個工作頁貼上的都覆蓋了 /.\
2) 我試著把貼好的"月結'的分頁另存作一個新的工作表,並且把一併存檔的巨集指令及圖案按鈕刪除,但我只能做到開了一個新檔案,不會自動存檔及刪除巨集指令及圖案按鈕

十分感謝幫忙

test save&clear.zip (18.78 KB)

大家好,我第一次發帖,如果有什麼不對的請見諒
因為每月都要上交月結報表,不想再剪剪貼貼,所以在嘗試用 ...
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 ' 重複性作業利用物件陣列與迴圈完成

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

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

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

  45.       .Close False
  46.     End With
  47. End Sub
複製代碼
test save&clear-a.zip (22.04 KB)

TOP

回復 2# luhpro


   十分感謝幫忙:handshake :handshake

TOP

參考檔:
Xl0000397-1.rar (13.92 KB)

TOP

回復 4# 准提部林
先謝謝幫忙,但有問題想請教一,就是如果用這個篩選出來的資料,能給出固定欄嗎?
我試了好幾天也只能做到把篩選出來的資料在貼上的時候向下移數行或右移數欄才貼上,就是不能收窄複製的欄數
只需要30欄,但怎樣也改不到,希望能夠幫忙,謝謝


,
         If .FilterMode Then .ShowAllData
         .[b7].AutoFilter Field:=2, Criteria1:=xS.[j2]
         .AutoFilter.Range.Offset(1, 2).Copy xS.Cells(Rows.Count, 1).End(xlUp)(2)
         .ShowAllData

TOP

回復 5# lovenice831


30欄是連續的嗎??? 還是跳躍的???
第幾欄到幾欄???

TOP

回復 6# 准提部林


    不好意思,我說得不太清楚,是連續的,由C 欄到 AF 欄,其實是否只要我篩選這列也能逹到這個效果呢? 謝謝解答

TOP

回復 7# lovenice831

Sub 月結()
Dim xS As Worksheet, T$, i&, xE As Range
Call 清除
Set xS = Sheets("月結")
If xS.[C1] = "" Then MsgBox "請輸入篩選文字!  ": Exit Sub
For i = 1 To 2
    With Sheets(i)
         If .FilterMode Then .ShowAllData '若工作表篩選中, 顯示[全部]
         .[A2].AutoFilter Field:=2, Criteria1:=xS.[C1] '執行篩選
          Set xE = xS.Cells(Rows.Count, 1).End(xlUp)(2)
         .AutoFilter.Range.Offset(1, 2).Resize(, 30).Copy xE '複製篩選資料  '2 = c欄 (從A欄算起0-1-2)
         .ShowAllData '恢復顯示[全部]
    End With
Next i
End Sub

TOP

回復 8# 准提部林
謝謝幫忙,但我不知出現什麼問題,試著試著,現在全都用不到,麻煩幫忙查看一下,謝謝


    test Inventory.rar (486.34 KB)

TOP

回復 9# lovenice831


我的舊版excel打不開附件,
看別人能否幫忙~~

TOP

        靜思自在 : 人生不一定球球是好球,但是有歷練的強打者,隨時都可以揮棒。
返回列表 上一主題