Question

我需要一个宏来复制文件夹中所有文件的标签，并将它们合并到一个工作簿中。我有一个当前的代码，它会拉动标签，但它们会变回空白。我需要将原始文件中的所有数据合并到一个文件中。有人能帮我解决这个问题吗？先感谢您。

Sub CreateSheet(worksheetname)
With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = worksheetname
End With
End Sub


Sub WorksheetLoop()

     Dim WS_Count As Integer
     Dim I As Integer

     ' Set WS_Count equal to the number of worksheets in the active
     ' workbook.
     WS_Count = ActiveWorkbook.Worksheets.Count

     ' Begin the loop.
     For I = 1 To WS_Count

        ' Insert your code here.
        ' The following line shows how to reference a sheet within
        ' the loop by displaying the worksheet name in a dialog box.
        CreateSheet (ActiveWorkbook.Worksheets(I).Name)

     Next I

  End Sub


Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
 myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
  Set wb = Workbooks.Open(Filename:=myPath & myFile)

'Ensure Workbook has opened before moving on to next line of code
  DoEvents
Call WorksheetLoop
'Change First Worksheet's Background Fill Blue
'wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)


'Save and Close Workbook
  wb.Close SaveChanges:=True

'Ensure Workbook has closed before moving on to next line of code
  DoEvents

'Get next file name
  myFile = Dir
Loop


ResetSettings:
'Reset Macro Optimization Settings
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

End Sub

Answer 1

将您的WorksheetLoop程序替换为以下代码。这会将每个工作表从引用的（OpenedBook）工作簿复制到ThisWorkbook。

Sub WorksheetLoop(OpenedBook As Workbook)

    Dim wrksht As Worksheet

    With ThisWorkbook
        For Each wrksht In OpenedBook.Worksheets
            wrksht.Copy Before:=.Worksheets(.Worksheets.Count)
        Next wrksht
    End With

End Sub

在LoopAllExcelFilesInFolder程序中更改此行代码：

Call WorksheetLoop

到

WorksheetLoop wb

如果您要打开的工作簿包含公开活动中的代码，您可能需要添加（我知道有更好的方式，而且我现在无法想到）：

Application.EnableEvents = False
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Application.EnableEvents = True

Answer 2

我认为您不能使用自定义名称创建新工作表，只需使用默认名称。但是你可以立即重命名它。

试试这个：

django==1.9
djangorestframework==3.3.3
mongoengine==0.9
pymongo==2.7
django-rest-framework-mongoengine

Answer 3

可以在子过程中设置参数并使用复制命令。

Sub WorksheetLoop(WB As Workbook)

     Dim WS_Count As Integer
     Dim I As Integer
     Dim myWB As Workbook

     Set myWB = ThisWorkbook
     ' Set WS_Count equal to the number of worksheets in the active
     ' workbook.
     WS_Count = WB.Worksheets.Count

     ' Begin the loop.
     For I = 1 To WS_Count

        ' Insert your code here.
        ' The following line shows how to reference a sheet within
        ' the loop by displaying the worksheet name in a dialog box.
        'CreateSheet (ActiveWorkbook.Worksheets(I).Name)
        WB.Worksheets(I).Copy after:=myWB.Sheets(myWB.Sheets.Count)

     Next I

  End Sub


Sub LoopAllExcelFilesInFolder()

Dim WB As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
 myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
  Set WB = Workbooks.Open(Filename:=myPath & myFile)

'Ensure Workbook has opened before moving on to next line of code
  DoEvents
 WorksheetLoop WB
'Change First Worksheet's Background Fill Blue
'wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)


'Save and Close Workbook
  WB.Close SaveChanges:=True

'Ensure Workbook has closed before moving on to next line of code
  DoEvents

'Get next file name
  myFile = Dir
Loop


ResetSettings:
'Reset Macro Optimization Settings
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

End Sub

我当前的代码复制选项卡，但不复制数据

3 个答案: