仕事メモ
Sub 集計マクロ()
Application.ScreenUpdating = False
Dim i As Long, ID As Long, fname As String, bookname As String, sumifolda As String, motofaile As String
Dim m As Worksheet
fname = "一覧表.xlsx"
sumifolda = "処理済"
motofaile = ThisWorkbook.Path & "\" & "コピー元ファイル.xlsx"
If Dir(ThisWorkbook.Path & "\" & fname) <> "" Then
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & fname
Debug.Print fname
Set m = Sheets("マスタ一覧")
For i = 3 To m.Cells(Rows.Count, 1).End(xlUp).Row
ID = Cells(i, 1).Value
bookname = Cells(i, 2).Value
Workbooks.Open Filename:=motofaile
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sumifolda & "\" & ID & bookname & ".xlsx"
ActiveWorkbook.Close savechanges:=True
Next
End If
End Sub
![](https://i0.wp.com/kozahiro.com/wp-content/uploads/2021/06/07bc32e80873d67b86b740c1225ff37e.jpg?resize=1024%2C236&ssl=1)
![](https://i0.wp.com/kozahiro.com/wp-content/uploads/2021/06/a476b4ea2b0fb47036fc7255d880da50.jpg?resize=680%2C475&ssl=1)
アンケート集計(同一フォルダのエクセルを開いてアンケート一覧へ転記処理)
Sub アンケート集計()
Dim フォルダー名 As String
Dim ファイル名 As String
Dim i
i = 5
Dim 氏名
Dim 回答1
Dim 回答2
Dim 回答3
フォルダー名 = ThisWorkbook.path & "\"
ファイル名 = Dir(フォルダー名 & "*.xlsx")
With ThisWorkbook.Sheets("アンケート一覧")
Range("C4").CurrentRegion.Offset(1, 0).ClearContents
End With
Do While ファイル名 <> ""
Workbooks.Open (フォルダー名 & ファイル名)
With Sheets("アンケート")
氏名 = Range("B3")
回答1 = Range("B5")
回答2 = Range("B6")
回答3 = Range("B6")
End With
With ThisWorkbook.Sheets("アンケート一覧")
.Cells(i, "C") = 氏名
.Cells(i, "D") = 回答1
.Cells(i, "E") = 回答2
.Cells(i, "F") = 回答3
End With
ActiveWorkbook.Close (フォルダー名 & ファイル名)
i = i + 1
ファイル名 = Dir()
Loop
End Sub
![](https://i0.wp.com/kozahiro.com/wp-content/uploads/2021/07/66c19942ab4ba346fdb64ccc04cde373.jpg?resize=896%2C640&ssl=1)
![](https://i0.wp.com/kozahiro.com/wp-content/uploads/2021/07/7aa7c21f94bcf4d1c6430e42e7e706b7.jpg?resize=493%2C389&ssl=1)