我有这个代码，首先检查工作簿是否在特定文件夹中，如果是，则复制所有文件夹 将该文件中的工作表放入现有工作簿中。
我想修改下面的代码来执行以下操作：
我不想将每个标签的内容复制并粘贴到新工作簿，而是想移动整个工作簿 选项卡到新工作簿没有（在新工作簿上创建另一个副本）..目标是能够 移动所有内容。当前移动数据的方式的问题在于它没有带来数据 图像
你可以在这里找到代码（第二个答案）
VBA to loop through a folder find a worksheet open it and move all tabs to another workbook
Public Sub ConsolidateSheets()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rngArea As Range
Dim lrowSpace As Long
Dim lSht As Long
Dim lngCalc As Long
Dim lngRow As Long
Dim lngCol As Long
Dim X()
Dim bProcessFolder As Boolean
Dim bNewSheet As Boolean
Dim StrPrefix
Dim strFileName As String
Dim strFolderName As String
'variant declaration needed for the Shell object to use a default directory
Dim strDefaultFolder As Variant
bProcessFolder = True
'set default directory here if needed
strDefaultFolder = "G:\Operations\test\"
'If the user is collating all the sheets to a single target sheet then the row spacing
'to distinguish between different sheets can be set here
lrowSpace = 1
If bProcessFolder Then
strFolderName = BrowseForFolder(strDefaultFolder)
'Look for xls, xlsx, xlsm files
strFileName = Dir(strFolderName & "\*401kk*.xls*")
Else
strFileName = Application _
.GetOpenFilename("Select file to process (*.xls*), *.xls*")
End If
Set Wb1 = Workbooks.Add(1)
Set ws1 = Wb1.Sheets(1)
If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")
'Turn off screenupdating, events, alerts and set calculation to manual
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
'set path outside the loop
StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)
Do While Len(strFileName) > 0
'Provide progress status to user
Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
'Open each workbook in the folder of interest
Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
If Not bNewSheet Then
'add summary details to first sheet
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
End If
For Each ws2 In Wb2.Sheets
If bNewSheet Then
'All data to a single sheet
'Skip importing target sheet data if the source sheet is blank
Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)
If Not rng2 Is Nothing Then
Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
'Find the first blank row on the target sheet
If Not rng1 Is Nothing Then
Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
'Ensure that the row area in the target sheet won't be exceeded
If rng3.Rows.Count + rng1.Row < Rows.Count Then
'Copy the data from the used range of each source sheet to the first blank row
'of the target sheet, using the starting column address from the source sheet being copied
ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
Else
MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
"sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
Wb2.Close False
Exit Do
End If
'colour the first of any spacer rows
If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
Else
'target sheet is empty so copy to first row
ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
End If
End If
Else
'new target sheet for each source sheet
ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
'Remove any links in our target sheet
With Wb1.Sheets(Wb1.Sheets.Count).Cells
.Copy
.PasteSpecial xlPasteValues
End With
On Error Resume Next
Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
'sheet name already exists in target workbook
If Err.Number <> 0 Then
'Add a number to the sheet name till a unique name is derived
Do
lSht = lSht + 1
Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
Loop While Not ws3 Is Nothing
lSht = 0
End If
On Error GoTo 0
End If
Next ws2
'Close the opened workbook
Wb2.Close False
'Check whether to force a DO loop exit if processing a single file
If bProcessFolder = False Then Exit Do
strFileName = Dir
Loop
'Remove any links if the user has used a target sheet
If bNewSheet Then
With ws1.UsedRange
.Copy
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).Activate
End With
Else
'Format the summary sheet if the user has created separate target sheets
ws1.Activate
ws1.Range("A1:B1").Font.Bold = True
ws1.Columns.AutoFit
End If
With Application
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = lngCalc
.StatusBar = vbNullString
End With
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
答案 0 :(得分：0)
您可以尝试使用以下代码将整个标签复制到循环中的当前工作簿中。
Sheets("Sheet1").Copy Before:=Workbooks("Book1").Sheets(1)