各位老師：
我做了一個把指定檔案夾下面的excel檔案進行匯總的VBA程式（參考了其它老師的代碼）。思路是：
功能1（遍歷作業薄）、先把指定檔案的檔案都逐一打開，并保持到當今檔案的里（新建一個sheet，并把sheet命名為“作業薄名”+“sheet名”）
功能2（匯總sheet）、把當前excel檔案里，除了“主表”sheet的內容，逐一copy到“主表”sheet里面
功能3（洗掉sheet）、洗掉前excel檔案里，除了“主表”sheet的其它所有sheet
開始，這三個功能都能運行，但運行了一段時間后，功能1就不能用了。
多次測驗，當初步分析。應該是功能3（洗掉sheet），導致sheet發生某種變化，產生的問題，也使Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count) 不能正常運行。
K=K+1是正常的
陳述句一模一樣，新建excel，就可以正常運行，但幾次后就不能運行，新建的excel也不能運行了。麻煩各位老師幫忙看看，是什么原因產生的。
正常時的圖片
非正常是的圖片
陳述句
Private Sub CommandButton1_Click()
Dim strPath$, strBookName$, strKey1, strKey2, strShtName$, k&
Dim Sht As Worksheet, shtActive As Worksheet
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then strPath = .SelectedItems(1) Else: Exit Sub
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strKey1 = InputBox("請輸入作業簿名稱所包含的關鍵詞。" & vbCr & "關鍵詞可以為空，如為空，則默認選擇全部作業簿")
If StrPtr(strKey1) = 0 Then Exit Sub
'如果用戶點擊了取消或關閉按鈕，則退出程式
strKey2 = InputBox("請輸入作業表名稱所包含的關鍵詞。" & vbCr & "關鍵詞可以為空，如為空，則默認選擇符合條件作業簿的全部作業表")
If StrPtr(strKey2) = 0 Then Exit Sub
Set shtActive = ActiveSheet
'當前作業表，賦值變數,代碼運行完畢后，回到此表
strBookName = Dir(strPath & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While strBookName <> ""
If strBookName = ThisWorkbook.Name Then
MsgBox "注意：指定檔案夾中存在和當前表格重名的作業簿！！" & vbCr & "該作業簿無法打開，作業表無法復制。"
'當出現重名作業簿時，提醒用戶。
Else
If InStr(1, strBookName, strKey1, vbTextCompare) Then
'作業簿名稱是否包含關鍵詞，關鍵詞不區分大小寫
With GetObject(strPath & strBookName)
For Each Sht In .Worksheets
If InStr(1, Sht.Name, strKey2, vbTextCompare) Then
'作業表名稱是否包含關鍵詞，關鍵詞不區分大小寫
If Application.CountIf(Sht.UsedRange, "<>") Then
'如果表格存在資料區域
strShtName = Split(strBookName, ".xls")(0) & "-" & Sht.Name
'復制來的作業表以"作業簿-作業表"形式起名。
ThisWorkbook.Sheets(strShtName).Delete
'如果已存在相關表名，則洗掉
Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count)
k = k + 1
'復制Sht到代碼所在作業簿所有作業表的后面，并累計個數
ActiveSheet.Name = strShtName
'作業表命名。
End If
End If
Next
.Close False
'關閉作業簿
End With
End If
End If
strBookName = Dir
'下一個符合條件的檔案
Loop
shtActive.Select
'回到初始作業表
MsgBox "作業表收集完畢，共收集：" & k & "個"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub CommandButton2_Click()
Dim Sht As Worksheet
Application.DisplayAlerts = False
For Each Sht In Worksheets
If Sht.Name <> "主表" Then
Sht.Delete
End If
Next
Application.DisplayAlerts = True
Set Sht = Nothing
End Sub
Private Sub CommandButton3_Click()
Dim Sht As Worksheet
Dim Str As String
Dim Rng As Range, Rng_O As Range
i = 0
For Each Sht In Worksheets
If Sht.Name <> "主表" Then
Set Rng = Sht.UsedRange
Rng.Copy Sheets("主表").Cells(i + 1, 2)
Sheets("主表").Cells(i + 1, 1) = Sht.Name
i = Cells(Rows.Count, 2).End(xlUp).Row
End If
Next
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/226513.html
上一篇：在django中，如果使用form表單的form.as_p，自動添加，怎么把后臺的資料傳回去
下一篇：單片機濾除教室內的工頻干擾