ワークシートをループし、新しいシートの行にキー情報を保存する

Question

ワークブックを開き、いくつかの重要なデータを抜き出して「概要」スプレッドシートに貼り付けるコードを作りたいと思います私はそれをAccessに読み込むことができます。

例： 私は3つの書類Book1、Book2、Book3を持っています。 Sheet1の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に貼り付けます。

新しい文書の3行目にBook3と同じものを貼り付けます。

ect。

私は、フォルダ内のすべてのワークシートをループし、このコードが見つかりました：私はまた、1つのブックからコピーして別のものに貼り付けるこのコードを見つけましたが、私はハードを持って

---

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 

---

をそれらの2つを組み合わせて作業してください。

助けてください！

'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