|
Private Sub CommandButton1_Click()
Dim FName As Variant, CAry As Variant, x As Variant
Dim MyB As Workbook, TgB As Workbook
Dim MyS As Worksheet
Dim i As Long, j As Long
With Application
FName = _
.GetOpenFilename("Excelファイル,*.xls,すべてのファイル,*.*", _
MultiSelect:=True)
If VarType(FName) = 11 Then Exit Sub
'↑他には If Not IsArray(FName) Then という条件なども可能
.ScreenUpdating = False
End With
On Error Resume Next
Set MyB = Workbooks("出力フォーム.xls")
If Err.Number <> 0 Then
Set MyB = Workbooks _
.Open(ThisWorkbook.Path & "\出力フォーム.xls")
Err.Clear
End If
On Error GoTo 0
Set MyS = MyB.Worksheets("Sheet1")
CAry = Array(1, 2, 10, 14, 16)
For Each x In FName
Set TgB = Workbooks.Open(x)
With TgB.Worksheets(1)
NyS.Range("A6").Value = .Range("G1").Value
MyS.Range("B6").Value = .Range("G2").Value
For i = 0 To 4
MyS.Range(MyS.Cells(6, i + 20), MyS.Cells(19, i + 20)) _
.Value = _
.Range(.Cells(17, CAry(i)), .Cells(30, CAry(i)).Value
Next i
End With
TgB.Close False: Set TgB = Nothing
MyB.SaveCopyAs Format(Now, "yy-mm-dd hh-mm-ss") & _
" _" & CStr(i) & ".xls"
Next
Set MyS = Nothing: Set MyB = Nothing
End Sub
で、どうでしょーか ?
|
|