Question

Sub Button3_Click()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

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 = "*.xlsx"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
    Set newWb = Workbooks.Add
    With newWb
        .SaveAs Filename:=myPath & Left(myFile, 5) & "_import.xlsx"
    End With
'Loop through each Excel file in folder
  i = 2
  Do While myFile <> ""

    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)
      Set newWb = Workbooks.Open(Filename:=myPath & Left(myFile, 5) & "_import.xlsx")
    'Change First Worksheet's Background Fill Blue
      wb.Sheets("Textual elements").Range("J11").Copy _
      Destination:=newWb.Sheets("Sheet1").Cells(i, 1)
      wb.Worksheets("Textual elements").Range("J31").Copy _
      Destination:=newWb.Worksheets("Sheet1").Cells(i, 2)

    i = i + 1

    'Save and Close Workbook
      newWb.Close SaveChanges:=True
    'Get next file name
      myFile = Dir()
  Loop
'Message Box when tasks are completed
  MsgBox "Task Complete!"

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

End Sub

所以我从下面的网站尝试根据我的需要编辑代码，但是我在调试模式下得到错误的斜体行。

目的是打开一个名为选择文件夹的新工作簿，并将单元格复制到特定单元格。

http://www.thespreadsheetguru.com/the-code-vault/2014/4/23/loop-through-all-excel-files-in-a-given-folder

Answer 1

我仍在使用Excel2002，因此它始终不能很好地与xlsx文件配合使用。也就是说，您可能不需要该行

set newWb = Workbooks.Open(Filename:=myPath & Left(myFile, 5) & "_import.xlsx")

因为我认为工作簿应该在添加时打开（在新版本中可能有所不同）。

将范围从一个工作簿复制到另一个工作簿

wb.Worksheets("Textual elements").Range("J11").Copy Destination:=newWb.Worksheets("Sheet1").Range(Cells(i, 1))

我不确定你是否有Do While myFile＆lt;＆gt; “”循环设置正确。您正在确保myFile＆lt;＆gt; “”然后做一些事情，但没有改变myFile的值，并再次检查myFile＆lt;＆gt; “”

此外，如果您运行此宏，它将在每次运行时覆盖指定的单元格，因此您只会获得最新的数据 - 只是因为这不是您尝试做的事情。

修改
当你刚刚打开它时，我仍然认为你不需要打开newwb - 可能最好使用F8＆amp; amp; F9来测试它。

关于复制，我是对的，你应该使用copy：destination，但是没有注意到你试图对一个单元格进行测距。它应该是Range（）OR cell（）。试试这个：

wb.Sheets("Textual elements").Range("J11").Copy _ Destination:=newWb.Sheets("Sheet1").Cells(i, 1) wb.Worksheets("Textual elements").Range("J31").Copy _ Destination:=newWb.Worksheets("Sheet1").Cells(i, 2)

副本末尾的空格下划线'_'只是为了便于阅读，将代码转换为新行（因此它不会超出页面末尾）

在代码结束时，即使您没有进行任何更改，也会关闭wb并保存更改。我会将此更改为newwb并关闭wb而不保存更改。

Answer 2

Range-object没有Paste方法，因此无法识别Paste语句。因此错误。您可以使用PasteSpecial。

试试这个：

取代：

  wb.Worksheets("Textual elements").Range("J11").Copy
  newWb.Worksheets("Sheet1").Range(Cells(i, 1)).Paste
  wb.Worksheets("Textual elements").Range("J11").Copy
  newWb.Worksheets("Sheet1").Range(Cells(i, 2)).Paste

with：

 wb.Worksheets("Textual elements").Range("J11").Copy
 newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2)).PasteSpecial

或没有PasteSpecial：

 wb.Worksheets("Textual elements").Range("J11").Copy newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2))

或者甚至，如果你必须使用粘贴; - ）：

 wb.Worksheets("Textual elements").Range("J11").Copy
 newWb.Worksheets("Sheet1").Range(Cells(i, 1),Cells(i,2)).select
 ActiveSheet.Paste

如何复制特定单元格并粘贴到新工作簿

2 个答案: