Do it again and again

[Beilage]

Hi,

I'm still a newby at vba. So please ha patience with me. I use Excel 2007.

Ok..... I have 200 excelsheets and each of them with 20 questions. Now i want to do a new excelsheet. With all the answers in it. But I dont want use copy and paste. For one Sheet , you see it below, there is no Problem. But how can the script do this with all of the 200 excelsheets? - again and again!

Sub import_answers()
'
'
' Keyboard Shortcut: Ctrl+Shift+M
'
Workbooks.Open Filename:="N:\trusts\Trusts\answers\D13.xlsx"
Range("B5").Select
Selection.Copy
Windows("answers_0.1.xlsx").Activate
Range("B3").Select
ActiveSheet.Paste
Windows("D3.xlsx").Activate
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("answers_0.1.xlsx").Activate
Range("C3").Select
ActiveSheet.Paste
Range("D3").Select
Windows("D13.xlsx").Activate
ActiveWindow.Close
End Sub
I hope you know the the solution for that Problem.
Thanks.

 

[arthurbr]

Cross post
http://www.excelforum.com/excel-programming/791473-do-it-again-and-again.html

 

[jbeaucaire]

Assuming all the separate workbooks with the answers are all in that one folder, put this macro into your Answers_0.1 workbook and save it as a macro-enabled workbook.

Option Explicit

Sub Import_Answers()
Dim fPath As String, fName As String, NR As Long
Dim wsA As Worksheet, wb As Workbook

Set wsA = ThisWorkbook.Sheets("Sheet1") 'the summary sheet in this wb being created
NR = wsA.Range("B" & wsA.Rows.Count) _
    .End(xlUp).Row + 1                  'next empty row
fPath = "N:\trusts\Trusts\answers\"     'remember the final \ in this string
fName = Dir(fPath & "*.xlsx")           'get first filename

    Do While Len(fName) > 0             'loop til no more filenames
        
        Set wb = Workbooks.Open(fPath & fName)
        wsA.Range("B" & NR).Value = Range("B5").Value
        wsA.Range("C" & NR).Value = Range("B6").Value
        wb.Close False                  'close book, no changes
        
        fName = Dir                     'get next filename
        NR = NR + 1
    Loop

End Sub