| |
マクロは、まとめ用の新規ブックに入れるのが自然ですね。
まず新規ブックを一つ作り、VBEで標準モジュールを追加し、
そこへ以下のマクロを入れて「ブック名やシート名に注意して、
違っていたら実際の名前に修正してから」実行して下さい。
Sub Data_Collect()
Dim WS As Worksheet
Dim BkAry As Variant
Dim i As Long, xR As Long
Dim MyF As String, Snm As String
Set WS = ThisWorkbook.Worksheets(1)
BkAry = Array("A", "B", "C")
Application.ScreenUpdating = False
WS.Cells.ClearContents
For i = 0 To 2
MyF = Application.DefaultFilePath & _
"\" & BkAry(i) & ".xls"
Snm = StrConv(CStr(i + 1), 4)
Workbooks.Open MyF
With ActiveWorkbook.Worksheets(Snm)
xR = .Range("A65536").End(xlUp).Row
If i = 0 Then
.Range("A1:AF" & xR).Copy WS.Range("A1")
Else
.Range("A2:AF" & xR).Copy WS.Range("A65536") _
.End(xlUp).Offset(1)
End If
End With
ActiveWorkbook.Close False
Next i
Set WS = Nothing
End Sub
名前を検索してD.xlsに転記するマクロは
Sub Data_Cpy()
Dim Nm As String
Dim CkR As Variant
Dim WB As Workbook
With Worksheets(1)
If WorksheetFunction.CountA(.Range("A:A")) = 0 Then
Exit Sub
End If
Do
Nm = InputBox("検索する名前を入力して下さい")
If Nm = "" Then Exit Sub
CkR = Application.Match(Nm, .Range("A:A"), 0)
If IsError(CkR) Then MsgBox Nm & vbLf & "は見つかりません"
Loop While IsError(CkR)
.Range(.Cells(CkR, 2), .Cells(CkR, 32)).Copy
End With
Application.ScreenUpdating = False
On Error Resume Next
Set WB = Workbooks("D.xls")
If Err.Number <> 0 Then
Workbooks.Open ThisWorkbook.Path & "\D.xls"
Set WB = ActiveWorkbook: Err.Clear
End If
On Error GoTo 0
With WB.Worksheets(1)
.Activate
.Range("A:A").ClearContents
.Range("A1").PasteSpecial xlPasteValues, , , True
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Set WB = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
