| |
▼武藤 晃作 さん：
・まず、フォルダを１つ（任意の場所に）作成して、学生さんのブックを
すべて、そこに保存してください。
・新規ブックの標準モジュールに以下を貼り付けてください。
Ａ列、Ｃ列の見出し語は実際のものに変更してください。
また、学生さんのブック、処理後も閉じずにエクセル上に残していますが
処理後は自動的に閉じたほうがよければ、コメントアウトしたクローズ命令を
いかしてください。
・で、このマクロブックを任意の名前で上で作ったフォルダに保存した上で実行してください。
Sub Sample()
Dim myPath As String
Dim myBook As String
Dim TitleA As String
Dim TitleC As String
Dim colA As Variant, colC As Variant
Application.ScreenUpdating = False
myPath = ThisWorkbook.Path
TitleA = "項目A" '実際の見出し名にしてください。
TitleC = "項目C" '実際の見出し名にしてください
myBook = Dir(myPath & "\*.xls")
Do While myBook <> ""
If myBook <> ThisWorkbook.Name Then
Workbooks.Open myPath & "\" & myBook
With Worksheets(1)
colA = Application.Match(TitleA, .Rows(1), 0)
colC = Application.Match(TitleC, .Rows(1), 0)
If Not IsNumeric(colA) Or Not IsNumeric(colC) Then
MsgBox ActiveWorkbook.Name & "には所定の見出しがありません" & vbLf & _
"処理をスキップします"
ActiveWorkbook.Close savechanges:=False
Else
Sheets.Add after:=Sheets(Worksheets.Count)
.Columns(colA).Copy Destination:=Range("A1")
.Columns(colC).Copy Destination:=Range("B1")
Application.CutCopyMode = False
Application.DisplayAlerts = False
'ActiveWorkbook.Close True '必要ならこのコードを実行
Application.DisplayAlerts = True
End If
End With
End If
myBook = Dir()
Loop
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
