| |
上手くいくかどうか解りませんがコードにするとこんな
Sub シートの追加()
Dim Bookname As String
Dim i As Long, j As Long
Dim Shname As String
Dim Fname As String
Dim wkbDestination As Workbook
With ThisWorkbook.Worksheets("Menu")
' コピーされる側です｡
For j = 4 To 10 Step 3
For i = 5 To 29 Step 2
If .Cells(i, j).Value <> "" And .Cells(i, j - 1).Value <> "" Then
Shname = Trim(.Cells(i, j - 1).Value)
Exit For
End If
Next i
Next j
End With
Bookname = "設備点検.xls"
' コピー元です｡
Fname = Range("O29").Value & Bookname
Set wkbDestination = Workbooks.Open(FileName:=Fname)
Shname = GetSheetsName(Shname, wkbDestination)
With wkbDestination
If Shname <> "" Then
.Worksheets(Shname).Copy After:=ThisWorkbook.Sheets("Menu")
.Saved = True
Else
Beep
MsgBox "該当するシートが有りません"
End If
.Close
End With
Set wkbDestination = Nothing
End Sub
Private Function GetSheetsName(strName As String, _
wkbMark As Workbook) As String
Dim wksMark As Worksheet
For Each wksMark In wkbMark.Worksheets
If StrComp(Trim(wksMark.Name), _
Trim(strName), vbTextCompare) = 0 Then
GetSheetsName = wksMark.Name
Exit For
End If
Next wksMark
Set wksMark = Nothing
End Function
|
|
Hirofumi
- 05/4/7(木) 19:18 -
