| |
▼初心者ごろう さん：
もし Ver2 のようで合ってるなら、あとはそれをコードにするだけです。
コード化するとき、開くBookや 貼り付け先がちがうだけで、処理内容が
同じ部分は、サブプロシージャに独立させて、そこをCallするようにします。
↓こんな感じで。
(開いたBookのほうは何ら変更してないので 保存せず閉じています)
Sub 値だけ貼付けVer3()
Const myFolder = "\\kkk\hh\III\YY\DDDDD\DDD\PPPPP\"
Dim Book As Workbook
Application.ScreenUpdating = False
'(1)『その他.xls』を開いて 「集計」シートに値貼り付け
Set Book = Workbooks.Open(myFolder & "その他.xls")
CopyData Book.Sheets("その他"), "A13"
Book.Close
Set Book = Nothing
'(2)『１３.xls』を開いて 「集計」シートに値貼り付け
Set Book = Workbooks.Open(myFolder & "１３.xls")
CopyData Book.Sheets("QC")
CopyData Book.Sheets("AA")
Book.Close
Set Book = Nothing
'(3)『１４.xls』を開いて 「集計」シートに値貼り付け
Set Book = Workbooks.Open(myFolder & "１４.xls")
CopyData Book.Sheets("BB")
Book.Close
Set Book = Nothing
Application.ScreenUpdating = True
End Sub
'WS1:コピー元シート strCopyTo: コピー先先頭セル（[A13]のときのみ指定）
Private Sub CopyData(ByVal WS1 As Worksheet, Optional strCopyTo$ = "")
Dim y As Long
Dim CopyTo As Range
Dim WS2 As Worksheet
Set WS2 = Workbooks("集計.xls").Sheets("集計")
If IsMissing(strCopyTo) Then
Set CopyTo = WS2.Cells(65536, "A").End(xlUp).Offset(1)
Else
Set CopyTo = WS2.Range(strCopyTo)
End If
With WS1
y = .Cells(65536, "A").End(xlUp).Row 'A列のデータ最終行を求める
If y >= 13 Then '▼有効なデータがあったときのみ、 'コピーする
.Range("A13:L" & y).Copy
CopyTo.PasteSpecial Paste:=xlValues '値のみ貼りつける
Application.CutCopyMode = False
End If
End With
Set WS2 = Nothing
End Sub
|
|
kanabun
- 08/7/8(火) 13:16 -
