麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] VBA 移動儲存格位置，另存新檔及刪除 [打印本頁]

作者: lovenice831 時間: 2020-12-11 15:23 標題: VBA 移動儲存格位置，另存新檔及刪除

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

十分感謝幫忙

作者: luhpro 時間: 2020-12-11 23:55

大家好，我第一次發帖，如果有什麼不對的請見諒
因為每月都要上交月結報表，不想再剪剪貼貼，所以在嘗試用 ...
lovenice831 發表於 2020-12-11 15:23

我把 Module2 刪掉,
並把所有的程式都集中在Module1了 :

Public iI% ' 整個檔案內都可共用的變數或物件使用Public宣告於此,
Public lRows&
Public wsTar As Worksheet, wsSou(1 To 2) As Worksheet ' 重複性作業利用物件陣列與迴圈完成
Sub Auto_Open() ' 開啟活頁簿時會自動執行, 可放置會共用需先初始化的指令
Set wsTar = Worksheets("月結") ' 設定工作表物件變數
Set wsSou(1) = Worksheets("工作表1")
Set wsSou(2) = Worksheets("工作表2")
End Sub
Sub 月結_Click()
With wsTar
lRows = .Cells(Rows.Count, 1).End(xlUp).Row ' 從下往上找到最底下一列的列號
If lRows < 3 Then lRows = 3 ' 最小為3, 避免刪掉標題
.Range(.[A3], .Cells(lRows, 3)).Clear ' 清除上次產生的資料, 以便產生新資料
End With
For iI = 1 To 2 ' 對兩個工作表逐個取出需要的資料做處理
With wsSou(iI)
.Select ' 底下作用儲存格移到A欄最新資料列前,需先將工作表Select
.[A3].AutoFilter Field:=2, Criteria1:="台灣"
.Range(.[A3], .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 3)).Copy wsTar.Cells(Rows.Count, 1).End(xlUp).Offset(1)
' 拷貝需要的資料, 貼到月結工作表的資料最新列
.[A3].AutoFilter Field:=2
.Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).Offset(1).Select ' 作用儲存格移到A欄最新資料列-A欄從下往上算最底下一列的下方那格
End With
Next
wsTar.Select ' 顯示月結工作表
End Sub
Sub test_()
Dim Vsha
Dim wsNew As Worksheet, wsTemp As Worksheet
With Workbooks.Add
Set wsTemp = .ActiveSheet
wsTar.Copy before:=.Worksheets(1)
Set wsNew = .ActiveSheet
wsTemp.Delete
Set wsTemp = Nothing
With wsNew
.name = .[11]
For Each Vsha In .Shapes
Vsha.Delete
Next
.Parent.SaveAs ThisWorkbook.Path & Application.PathSeparator & .name
End With
.Close False
End With
End Sub

複製代碼

[attach]32790[/attach]

作者: lovenice831 時間: 2020-12-12 01:56

回復 2# luhpro

十分感謝幫忙:handshake :handshake

作者: 准提部林 時間: 2020-12-12 12:37

參考檔:
[attach]32797[/attach]

作者: lovenice831 時間: 2020-12-19 14:03

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

作者: 准提部林 時間: 2020-12-19 14:41

回復 5# lovenice831

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

作者: lovenice831 時間: 2020-12-21 14:14

回復 6# 准提部林

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

作者: 准提部林 時間: 2020-12-21 17:19

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

作者: lovenice831 時間: 2020-12-26 20:13

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

[attach]32885[/attach][attach]32885[/attach]

作者: 准提部林 時間: 2020-12-27 12:11

回復 9# lovenice831

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

作者: luhpro 時間: 2020-12-27 16:46

回復准提部林
謝謝幫忙，但我不知出現什麼問題，試著試著，現在全都用不到，麻煩幫忙查看一下，謝謝
...
lovenice831 發表於 2020-12-26 20:13

[attach]32893[/attach]

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

試試看...

作者: lovenice831 時間: 2020-12-28 10:36

回復 11# luhpro

先謝過，我試轉1 ，但轉一後只能顯示A 的結果，B 和C 的都依然是空白

作者: lovenice831 時間: 2020-12-28 10:49

回復 10# 准提部林

不好意思，我轉擋了並再上傳，麻煩了
[attach]32895[/attach]

作者: 准提部林 時間: 2020-12-28 12:43

回復 13# lovenice831

一樣打不開,
WITH SHEETS(1)
應該是
WITH SHEETS(i)

作者: lovenice831 時間: 2020-12-28 14:07

回復 14# 准提部林
好的，我再試一下，不好意思，麻煩你了

作者: luhpro 時間: 2020-12-28 21:37

本帖最後由 luhpro 於 2020-12-28 21:43 編輯

回復准提部林

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

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

以下是程式內容:

Sub Monthly()
Dim xS As Worksheet, T$, i&, xE As Range
Call clean
Set xS = Sheets("Monthly")
If xS.[j2] = "" Then MsgBox "please choose! ": Exit Sub
For i = 1 To 3
With Sheets(1)
If .FilterMode Then .ShowAllData
.[c8].AutoFilter Field:=1, Criteria1:=xS.[j2]
Set xE = xS.Cells(Rows.Count, 1).End(xlUp)(5)
.AutoFilter.Range.Offset(1, 2).Resize(, 30).Copy xE
.ShowAllData
End With
Next i
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)

作者: lovenice831 時間: 2020-12-29 16:19

回復 16# luhpro

謝謝你的解答，整體來說我之所以要三個迴圈是因為一個分頁等於一條生產線，每月尾都需要把各牌子的貨物分別做成月結表，所以需要這樣迴圈，謝謝幫忙

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)