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

標題: [發問] 如何用VBA 把SUBOROUTINE寫入特定WORKSHEET？ [打印本頁]

作者: 小俠客 時間: 2015-10-9 13:46 標題: 如何用VBA 把SUBOROUTINE寫入特定WORKSHEET？

本帖最後由小俠客於 2015-10-9 13:48 編輯

其實我有兩個問題想了解：

1) 如何能重設一個工作表的usedrange.address？
我寫的程式大概流程是：「清除某一工作表資料」>「寫入資料(當中會插入數個欄位)」>「在有資料的位置再作處理(usedrange)」。
但運行很多次後我發現，即使我的資料只是由A1:Q100，該工作表的usedrange.address變得很大(A1:ZQ100)，我猜是之前的插入欄位動作而影響。但無論我是用cells.delete或cells.clear，usedrange.address 都無法重設成我有資料的range，使程式運行得越來越慢。

由於我無法解決usedrange.address的錯誤，所以我改了程式，由「清除某一工作表資料」變成「刪除該工作表再重新加入同名字的工作表」，usedrange的問題算是解決了，但我又產生另一個問題
2) 如何用VBA 把SUBOROUTINE寫入特定WORKSHEET？
因為該工作表早已寫入一些subroutine，但刪除工作表時卻同時把工作表下的subroutine刪掉，請問有沒有方法加回那些subroutine?

問題實在奇怪，先謝謝大家。

作者: GBKEE 時間: 2015-10-11 14:43

回復 1# 小俠客

但無論我是用cells.delete或cells.clear，usedrange.address 都無法重設成我有資料的range

不太了解....你的問題

Sub Ex()
Application.VBE.Windows("即時運算").Visible = True
With Cells
.Range("A1:Q100") = "TEST"
Debug.Print UsedRange.Address
.Clear
Debug.Print UsedRange.Address
End With
End Sub

複製代碼

作者: 小俠客 時間: 2015-10-11 15:18

回復小俠客

不太了解....你的問題
GBKEE 發表於 2015-10-11 14:43

由於我無法運行你的代碼，所以我把代碼改成：

Sub Ex()
With ActiveSheet
Debug.Print "1：　"＆.UsedRange.Address
.Range("A1:Q100") = "TEST"
Debug.Print "２：　"＆.UsedRange.Address
.Cells.Clear
Debug.Print "３：　"＆.UsedRange.Address
.Cells.Delete
Debug.Print "４：　"＆.UsedRange.Address
End With
End Sub

複製代碼

結果是：
１：　$A$1:$AL$130
２：　$A$1:$AL$130
３：　$C$1:$AL$1
４：　$C$1:$AL$1

其實第一個「１：　$A$1:$AL$130」也是錯，因為那工作表中只在A1:Q130有資料，而每次我重寫資料時都用「Cells.Clear」把舊資料刪掉，但「UsedRange.Address」好像無法找到正確結果($A$1)。

題外話：我發覺EXCEL在重複使用「With QueryTables.Add」多次(約100次以上)後，每次匯入的時間都會減慢，無論我重新開啟EXCEL或重啟電腦，甚至把該工作表當中因匯入而產生的named range刪掉，匯入時間仍然很慢，不知道原因......

作者: 小俠客 時間: 2015-10-11 16:19

本帖最後由小俠客於 2015-10-11 16:32 編輯

對不起，我發現了問題，我相信是GROUP問題，如果不用GROUPING，好像usedrange.address便正常了
但我的程式也有用.Columns.Ungroup，可是問題仍然出現......

Sub Integrate()
Application.ScreenUpdating = False
Out.Cells.Clear
Out.Columns.Ungroup
Out.Cells.EntireColumn.Hidden = False
For i = 0 To 5
Out.Columns("B:D").Insert
Out.Columns("C:D").Columns.Group
Out.Cells(1, 2) = i & " / FY"
Out.Cells(1, 3) = i & " / 2H"
Out.Cells(1, 4) = i & " / 1H"
With RecordsetA
.MoveFirst
Do Until .EOF
Out.Cells(.Fields("Item_ID"), 2) = .Fields("FY").Value
Out.Cells(.Fields("Item_ID"), 3) = .Fields("Second_Half").Value
Out.Cells(.Fields("Item_ID"), 4) = .Fields("First_Half").Value
Out.Rows(.Fields("Item_ID")).NumberFormatLocal = .Fields("Format")
.MoveNext
Loop
End With
next i
ConfigCN.Close
Set ConfigCN = Nothing
Set RecordsetA= Nothing
Application.ScreenUpdating = True
End Sub

複製代碼

作者: 小俠客 時間: 2015-10-11 16:45

回復 2# GBKEE

Sub Integrate()
Set out = ActiveSheet
Application.ScreenUpdating = False
Debug.Print out.UsedRange.Address
On Error Resume Next
out.Cells.Clear
out.Columns.Ungroup
out.Cells.EntireColumn.Hidden = False
Debug.Print out.UsedRange.Address
For i = 0 To 5
out.Columns("B:D").Insert
out.Columns("C:D").Columns.Group
out.Cells(1, 2) = i & " / FY"
out.Cells(1, 3) = i & " / 2H"
out.Cells(1, 4) = i & " / 1H"
Next i
Application.ScreenUpdating = True
End Sub

複製代碼

這個代碼能夠重現usedrange的問題，是我的弄錯嗎？

作者: 准提部林 時間: 2015-10-11 17:38

本帖最後由准提部林於 2015-10-11 17:42 編輯

試試看：
Sub AR1011()
ActiveSheet.UsedRange.EntireColumn.Delete　'欄群組也一併取消
ActiveSheet.UsedRange.EntireRow.Delete　'列群組也一併取消
ActiveSheet.UsedRange.Delete　'此時，UsedRange 仍未釋放，再 Del 一次

MsgBox ActiveSheet.UsedRange.Address
End Sub

註：若欄列有隱藏（非群組的隱藏），還須再加指令使其顯示

作者: stillfish00 時間: 2015-10-12 09:53

因為該工作表早已寫入一些subroutine，但刪除工作表時卻同時把工作表下的subroutine刪掉，請問有沒有方法加回那些subroutine?

這問題怪怪的，subroutine會寫在工作表下通常表示只有該工作表會用到，自然刪掉也無所謂；
如果是要給所有工作表都能用的sub，寫在一般模組就好了。

題外話：我發覺EXCEL在重複使用「With QueryTables.Add」多次(約100次以上)後，每次匯入的時間都會減慢

用QueryTables會建立連線，如果只是用來取得資料，不需要保持連線，取完後就馬上刪除連線吧
你可以檢查資料>連線裡是不是很多不必要的連線。

*usedrange 抓不到要的範圍，附檔會比較容易找問題；不然就依資料情況看能否採用currentRegion 或其他定位的方法

作者: 小俠客 時間: 2015-10-12 11:59

本帖最後由小俠客於 2015-10-12 12:09 編輯

回復 6# 准提部林

謝謝版大幫忙，可惜我用了你的代碼還是無法解決問題...

現上傳了簡化了的程式
壓縮檔中的ACCESS檔是存放資料，大家可以開啟TEST檔，按short cut 「CTRL+Q」執行程式，之後輸入「1」便可以了，程式最後會顯示usedrange.address
為了減少檔案容量，所以CODE 1以外的資料都刪去......

作者: 小俠客 時間: 2015-10-12 12:06

回復 7# stillfish00

我也明白這個問題是怪怪，但刪除工作表是我解決usedrange.address錯誤的另類方法，可惜我在該工作表寫了selection change的subroutine，刪工作表時會把subroutine刪掉.....

「用QueryTables會建立連線，如果只是用來取得資料，不需要保持連線，取完後就馬上刪除連線吧
你可以檢查資料>連線裡是不是很多不必要的連線。」

這個可能是吧，我的白痴解決方法是...... 定期刪掉該工作表再重新建立.......
請問如何用VBA把工作表的連線刪掉？

「*usedrange 抓不到要的範圍，附檔會比較容易找問題；不然就依資料情況看能否採用currentRegion 或其他定位的方法」
已在8樓上傳了檔案，煩請查看

作者: stillfish00 時間: 2015-10-12 14:23

回復 9# 小俠客
1. 附檔手動刪除攔 T:ND 重跑，UsedRange.Address 就會顯示 $A$1:$S$31
或是 MsgBox Out.UsedRange.Address 也可以改為
With Out
      MsgBox .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)).Address
End With

2. 先手動刪除那些不用的連線
在你用 QueryTable 的程式碼(附件沒有我找不到) , refresh 後面加一行 delete
With ActiveSheet.QueryTables.Add(XXX)
      ..........
      .Refresh BackgroundQuery:=False
      .Delete
End With

3. selection change 是工作表事件，那些 code 也能移植到 ThisWorkbook 的 Workbook_SheetSelectionChange，只要你多判斷是否是你要觸發的工作表。

作者: 小俠客 時間: 2015-10-12 17:49

本帖最後由小俠客於 2015-10-12 17:50 編輯

回復 10# stillfish00

關於第2、3點，我回去再試試，謝謝

而第一點，我發現我在簡化上載程式時多刪了一句，實際程式：

With Out
.Columns(1).ColumnWidth = 35
.Range(Out.Cells(1, 2), .Cells(Out.Cells(10000, 1).End(xlUp).Row, .Cells(1, 100).End(xlToLeft).Column)).ColumnWidth = 10
Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End With

複製代碼

麻煩stillfish00大可以加回「.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1」再試嗎？
這句的目的是簡化顯示，但好像程式有了這句後，即使手動刪除攔 T:ND 重跑，UsedRange.Address 顯示也不正確.....

作者: 准提部林 時間: 2015-10-12 18:35

本帖最後由准提部林於 2015-10-12 18:36 編輯

回復 8# 小俠客

On Error Resume Next
Out.UsedRange.EntireColumn.Delete　'加這行　
Out.Cells.Clear
Out.Columns.Ungroup
Out.Cells.EntireColumn.Hidden = False
Out.UsedRange.Delete　'加這行　

這邊測都可以的～～

另個作法（範本引用）：　
空白工作表+貼好工作表事件VBA，命名為〔TMP〕，
建立新資料時，刪除舊表，複製此表重命名～～

作者: 小俠客 時間: 2015-10-13 09:15

本帖最後由小俠客於 2015-10-13 09:18 編輯

回復 12# 准提部林

版大，很抱歉，我在簡化上載程式時多刪了一句：「.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1」，我還是重新上載程式給各位大大指教......

有了這一句後，用了你提議的代碼也解決不了usedrange.address錯誤的問題

至於範本作法，我沒曾使用過範本，還以為範本需要在同一電腦使用，而我需要在不同電腦使用，要再爬文看看，先謝了。

作者: 准提部林 時間: 2015-10-13 10:10

回復 13# 小俠客

我只能測試刪除原有資料及解除群組,
即使用加入:.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Out.UsedRange.Address 也是 $A$1 無誤~~

所謂的〔範本〕，指的是〔工作表範本〕，這表是在同一檔案的，
您可手動新增一工作表，命名為〔TMP〕，將〔Output〕程式碼貼入，即為一範本工作表，

要執行程式時，再〔Call 呼叫〕以下副程式：　
Sub NewOutput()
On Error Resume Next
Application.DisplayAlerts = False
With ThisWorkbook
　　　.Sheets("Output").Delete
　　　.Sheets("TMP").Copy After:=.Sheets(.Sheets.Count)
　　　.Sheets(.Sheets.Count).Name = "Output"
End With
Application.DisplayAlerts = True
End Sub

這可以：
１．刪除舊〔Output〕工作表
２．複製〔TMP〕工作表，重新命名〔Output〕

每次都是完全空白的工作表，也解決Selection_Change程式碼的問題！

作者: 小俠客 時間: 2015-10-13 12:10

本帖最後由小俠客於 2015-10-13 12:16 編輯

回復 14# 准提部林

奇怪了，如果是用TEMP_V2的檔案，
第一次執行程式，輸入「1」，MSG是「$A1:$T$31」
再按「CTRL+Q」，輸入「1」，MSGBOX 是「$A1:$AK$31」
再按「CTRL+Q」，輸入「1」，MSGBOX 是「$A1:$BC$31」
但我預期的MSGBOX是「$A$1:$S$31」，因為只有$A$1:$S$31才有資料嘛.....

我是用OFFICE 2010，為什麼會有不一樣的結果？
我把我的測試POST在YOUTUBE，請大家看看：
https://www.youtube.com/watch?v=deM3JvNEeuY&feature=youtu.be
代碼是和temp_v2的完全一樣.....
也有加上大大的

On Error Resume Next
Out.UsedRange.EntireColumn.Delete '加這行
Out.Cells.Clear
Out.Columns.Ungroup
Out.Cells.EntireColumn.Hidden = False
Out.UsedRange.Delete '加這行

複製代碼

範本的功能不錯，看來可以一試，謝謝版大。

作者: stillfish00 時間: 2015-10-13 13:49

本帖最後由 stillfish00 於 2015-10-13 13:51 編輯

回復 15# 小俠客
看來是excel的問題，我把手動重現問題步驟描述如下
我也是excel2010，其他版本可試試:
1. 開新工作表
2. 選 B:D 欄，更改欄寬
3. 選 B:D 欄，群組
4. 點選群組左邊的1(第一層)
5. 點選群組左邊的2
6. 取消群組
7. 刪除 B:D 欄
8. VBA 執行 MsgBox ActiveSheet.UsedRange.Address

好像只要有動過群組的欄寬，又去摺疊群組，之後就清不乾淨了(刪除也無效)

作者: lpk187 時間: 2015-10-13 14:00

回復 15# 小俠客

因為其中有一句Out.Columns("B:D").Insert 插入儲存格範圍，而一直增加使用區域的！
若試著把這句註解掉，就不會增加了usedrange

作者: 小俠客 時間: 2015-10-13 15:08

回復 16# stillfish00
原來如此，如果真是EXCEL的BUG，那麼我們也沒有方法重設usedrange，唯有另行他法
大大提議的Workbook_SheetSelectionChange或版大提議的範本好像可行，只要我把CODE放在WORKBOOK，每次把舊的OUTPUT刪掉便可以
另外，QUERYTABLE加了.delete好像真的變快了，我再不用定期刪除WORKSHEET了.....

最後還是謝謝大家的協助~

作者: 小俠客 時間: 2015-10-13 15:11

回復 17# lpk187

應該不是，上面stillfish00大大的手動動作沒有加入insert動作，但usedrange仍然出錯
我想應該是stillfish00推論：調整欄闊、GROUP和UNGROUP同時使用後，usedrange便無法重設

作者: lpk187 時間: 2015-10-13 15:26

回復 19# 小俠客

你不覺得奇怪嗎？為什麼每次增的欄和你插入的一樣多嗎？

作者: 小俠客 時間: 2015-10-13 15:41

回復 20# lpk187

有呀，我以為是這樣：由於無法重設該工作表的USEDRANGE，所以每次在USEDRANGE中間insert了10欄，usedrange都會變大10欄
你可以試試用我的V2，最初的USEDRANGE是「$A$1:$S$31」，然後全選再全部清除資料，USEDRANGE變成「$C$1:$S$1」，所以每次程式INSERT COLUMNS，都會令USEDRANGE變大。而如果把insert那句刪去，程式便會把所有資料寫在B至D欄上，USEDRANGE便沒有變大
不知道是不是這樣，我是這樣解釋。

作者: lpk187 時間: 2015-10-13 16:07

本帖最後由 lpk187 於 2015-10-13 16:08 編輯

回復 21# 小俠客

有時候，試驗一下就知道，下面你試一下就知道不會增加！

Set LayoutRS = ConfigCN.Execute(LayoutSQL)
B = 2
C = 3
D = 4
For i = StartYear To EndYear
'Out.Columns("B:D").Insert
Out.Range(Columns(C), Columns(D)).Columns.Group
Out.Cells(1, B) = i & " / FY"
Out.Cells(1, C) = i & " / 2H"
Out.Cells(1, D) = i & " / 1H"
With LayoutRS
.MoveFirst
Do Until .EOF
If Out.Cells(.Fields("Item_ID"), 1) = "" Then
Out.Cells(.Fields("Item_ID"), 1) = .Fields("Item_Name").Value
'End If
End If
.MoveNext
Loop
End With
DataSQL = "select * from tbl_Income_Sub where Code = " & Code & " and S_Year = '" & i & "'"
Set DataRS = DataCN.Execute(DataSQL)
With DataRS
Do Until .EOF
Select Case .Fields("Term")
Case "1H"
TargetCol = D
Case "FY"
TargetCol = B
End Select
Out.Cells(2, TargetCol) = .Fields("Currency")
Out.Cells(3, TargetCol) = .Fields("Unit")
Out.Cells(4, TargetCol) = .Fields("Report_Date")
CurrUnit = .Fields("Unit")
If TargetCol = B Then
Out.Cells(2, TargetCol + 1) = .Fields("Currency")
Out.Cells(3, TargetCol + 1) = .Fields("Unit")
Out.Cells(4, TargetCol + 1) = .Fields("Report_Date")
End If
.MoveNext
Loop
End With
DataSQL = "select * from tbl_Income where Code = " & Code & " and S_Year = '" & i & "'"
Set DataRS = DataCN.Execute(DataSQL)
With DataRS
Do Until .EOF
If Not Out.Columns(1).Find(.Fields("Item"), lookat:=xlWhole) Is Nothing Then
TargetRow = Out.Columns(1).Find(.Fields("Item"), lookat:=xlWhole).Row
Select Case .Fields("Term")
Case "1H"
TargetCol = D
Case "FY"
TargetCol = B
End Select
Out.Cells(TargetRow, TargetCol) = Round(.Fields("Amount"), 4)
End If
.MoveNext
Loop
End With
B = B + 3
C = C + 3
D = D + 3
Next i

複製代碼

作者: stillfish00 時間: 2015-10-13 16:38

回復 22# lpk187
重點不是這個吧 ...
現在是在說明明沒資料沒格式的儲存格，usedrange 在某些情況會誤判為有使用。

作者: 小俠客 時間: 2015-10-13 16:44

回復 22# lpk187

謝謝你的指教，的確如此，雖然這個做法是可以令USEDRANGE不變大，但USEDRANGE的資料仍然不正確
如果執行了你提供的代碼後，手動把所有的資料刪除，USEDRANGE仍然顯示：$C$1:$T$1

作者: lpk187 時間: 2015-10-14 11:23

回復 24# 小俠客

不好意思！原來我沒看前面的討論，真抱歉！
我試了不少方法，最後有發現，在結束活頁簿之前清空工作表。再打開的時候，就會恢復歸零的UsedRange。你可以試試看！

作者: Scott090 時間: 2015-11-1 16:21

回復 24# 小俠客

看看下列程式能不能適合使用

Sub CompactSheet()
Dim ws As Worksheet
Dim R%, C%
Set ws = Sheets("Output")
With ws
ws.[A1].Select
Debug.Print .UsedRange.Address
On Error Resume Next
.Cells.Ungroup
.Cells.EntireColumn.Hidden = False
.Cells.Delete
'Copy 一區沒有隱藏過的 Columns 到 .UsedRange
[A1].Select
Debug.Print .UsedRange.Address
C = .UsedRange.Columns.Count
Range("A1").Resize(.Rows.Count, C).Copy .UsedRange
[A1].Select
Debug.Print .UsedRange.Address
On Error GoTo 0
End With
End Sub

複製代碼

作者: 小俠客 時間: 2015-11-3 12:23

回復 26# Scott090

謝謝你，我把你的代碼複製一次，當成RESET USEDRANGE.ADDRESS，但可惜未能成功。
可能是excel的BUG，無法解決...

作者: Scott090 時間: 2015-11-4 23:53

回復 27# 小俠客

這個用 13# 的附件試過

Sub CompactSheet()
Dim ws As Worksheet
Dim C%, Col%
Set ws = Sheets("Output")
ws.Select
With ws
' .[A1].Select
Debug.Print .UsedRange.Address
On Error Resume Next
' .Cells.Ungroup
' .Cells.EntireColumn.Hidden = False
If ActiveWindow.FreezePanes Then ActiveWindow.FreezePanes = False
' Columns("A:Z").Delete Shift:=xlToLeft
Col = .UsedRange.Column
C = .UsedRange.Columns.Count
.Cells(1, Col).Resize(.Rows.Count, C).Delete Shift:=xlToLeft
.[A1].Select
Debug.Print .UsedRange.Address
On Error GoTo 0
End With
End Sub

複製代碼

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