I made a excel file to specify folders below summarize the VBA program code (refer to the other teachers), the idea is:
Function (1) through work thin, first open the specified file the documents one by one, and keep to today's file (create a new sheet, and the sheet named "work of thin" + "sheet name")
Function 2 (summary sheet), the current in the excel file, in addition to the content of the "of" the main table sheet, one copy to "the main table sheet inside
"Before deleting function 3 (delete sheet), in the excel file, in addition to the main table "sheet of all the other sheet
Start, these three functions can run, but run after a period of time, function 1 cannot be used,
Testing for many times, when the preliminary analysis, it should be function 3 (delete sheet), lead to some changes in your sheet, problems, also make the Sht. Copy after:=ThisWorkbook. Worksheets (Sheets. Count) can not run normally,
K=K + 1 is a normal
Statements are identical, the newly built excel, you can run normally, but after a few times can't run, the new excel also cannot run, troublesome everybody the teacher look, what the causes of the
The picture of the normal
Abnormal yes picture
Statement
Private Sub CommandButton1_Click ()
Dim strPath $, strBookName $, strKey1, strKey2, strShtName $, k&
Dim Sht As Worksheet, shtActive As Worksheet
On the Error Resume Next
With the Application. The FileDialog (msoFileDialogFolderPicker)
If the Show Then strPath=. SelectedItems (1) the Else: Exit Sub
End With
If Right (strPath, 1) & lt;> "" Then strPath=strPath & amp; ""
StrKey1=InputBox (" keyword, please enter the name of the workbook contains "& amp; VbCr & amp; "Keyword can be null, such as empty, the default choice all workbook")
If StrPtr (strKey1)=0 Then the Exit Sub
'if you click on the cancel or close button, then exit the program
StrKey2=InputBox (" please enter the keywords, work table name contains "& amp; VbCr & amp; "Keyword can be null, such as empty, the default selection of qualified workbook all worksheet")
If StrPtr (strKey2)=0 Then the Exit Sub
The Set shtActive=ActiveSheet
'current working table, assignment variable, after the code runs, back to the table
StrBookName=Dir (strPath & amp; * "" *. XLS)
Application. ScreenUpdating=False
Application. DisplayAlerts=False
The Do While strBookName & lt;> "
"If strBookName=ThisWorkbook. Name Then
MsgBox "note: the specified folder exists and the current form the nuptial workbook!! "& amp; VbCr & amp; "This workbook does not open, work table could not be copied,"
'when the nuptial workbook, remind users,
The Else
If InStr (1, strBookName, strKey1 vbTextCompare) Then
'the name of the workbook contains keywords, keyword case-insensitive
With GetObject (strPath & amp; StrBookName)
For Each Sht. In Worksheets
If InStr (1, Sht. Name, strKey2, vbTextCompare) Then
'work table name contains keywords, keyword case-insensitive
If Application. CountIf (Sht) UsedRange, "& lt; & gt;" ) Then
'if the form is the data area
StrShtName=Split (strBookName, ". XLS ") (0) & amp; "-" & amp; Sht. Name
'replication to the worksheet in the form of "workbook - work table" the name,
ThisWorkbook. Sheets (strShtName). Delete
'if the existing relevant name of the table, the delete
Sht. Copy after:=ThisWorkbook. Worksheets (Sheets. Count)
K=k + 1
'copy Sht to code in the back of the workbook all work table, and the cumulative number of
ActiveSheet. Name=strShtName
'worksheet, named
End the If
End the If
Next
. Close False
'close the workbook
End With
End the If
End the If
StrBookName=Dir
'the next eligible file
Loop
ShtActive. Select
'back to the initial schedule
MsgBox "worksheet collected, collect:" & amp; K & amp; "A"
Application. ScreenUpdating=True
Application. DisplayAlerts=True
End Sub
Private Sub CommandButton2_Click ()
Dim Sht As Worksheet
Application. DisplayAlerts=False
For Each Sht Worksheets In
If Sht. Name & lt;> "The main table" Then
Sht. Delete
End the If
Next
Application. DisplayAlerts=True
The Set of 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 Worksheets In
If Sht. Name & lt;> "The main table" Then
The Set of Rng=Sht. UsedRange
Rng. Copy Sheets (" table ") Cells (I + 1, 2)
Sheets (" table ") Cells (I + 1, 1)=Sht. Name
I=Cells (Rows. The Count, and 2) the End (xlUp). Row
End the If
Next
End Sub