Question

我想制作一段代码，打开一堆工作簿，提取一些关键数据并将其粘贴到某种概述中。电子表格，以便我可以将其加载到Access。

实施例：我有3个文件Book1，Book2和Book3。我希望来自sheet1的Cell A1，B2，B4，D6和来自sheet2的B2，B5，E9和来自Book1的sheet3的A1：C3将被粘贴到新文档中的第1行。

来自sheet1的单元格A1，B2，B4，D6和来自sheet2的B2，B5，E9和来自Book2的sheet3的A1：C3将被粘贴到新文档中的第2行。

同样来自Book3，将其粘贴到新文档的第3行。

等。

我发现这段代码循环遍历文件夹中的所有工作表：

Sub LoopAllExcelFilesInFolder()
'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 = "*.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

'SOME SMART CODE SHOULD BE HERE

'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

 '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

我还发现这个代码从一个工作簿复制并粘贴到另一个工作簿中，但我很难将这两个工作簿结合起来并使其工作。

请帮忙！

'SOURCE https://stackoverflow.com/questions/19351832/copy-from-one-workbook-
'and-paste-into-another
Dim x As Workbook, y As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

Set x = Workbooks.Open("path to copying book")
Set y = Workbooks.Open("path to pasting book")

Set ws1 = x.Sheets("Sheet you want to copy from")
Set ws2 = y.Sheets("Sheet you want to copy to")

ws1.Cells.Copy ws2.cells
y.Close True
x.Close False

Answer 1

这是非常直观的，基于您概述的问题陈述，但根据您对实际内容的了解进行一些调整，您可以添加一些变量以使其稍微不那么硬编码。

那就是说，从理论上说，我认为这与你想要的一致：

Dim wb, newWorkbook As Workbook
Dim ws, newWorksheet As Worksheet
Dim idx, row, col As Integer
Dim cell As Range

Set newWorkbook = Workbooks.Add
Set newWorksheet = newWorkbook.Sheets(1)
row = 1

For Each wb In Workbooks

  If wb.Name <> newWorkbook.Name Then
    Set ws = wb.Sheets("Sheet1")
    newWorksheet.Cells(row, 1).Value = ws.Range("A1").Value
    newWorksheet.Cells(row, 2).Value = ws.Range("B2").Value
    newWorksheet.Cells(row, 3).Value = ws.Range("B4").Value
    newWorksheet.Cells(row, 4).Value = ws.Range("D6").Value

    Set ws = wb.Sheets("Sheet2")
    newWorksheet.Cells(row, 5).Value = ws.Range("B2").Value
    newWorksheet.Cells(row, 6).Value = ws.Range("B5").Value
    newWorksheet.Cells(row, 7).Value = ws.Range("E9").Value

    Set ws = wb.Sheets("Sheet3")
    col = 8
    For Each cell In ws.Range("A1:C3")
      newWorksheet.Cells(row, 7).Value = cell.Value
      col = col + 1
    Next cell

    row = row + 1
  End If
Next wb

循环工作表并将key-info保存到新工作表中的行

1 个答案: