セルコピー

Option Explicit

'========================================
'自動セル転記
'========================================
Sub CopyCellAuto()

Dim setsheet
Dim cntrow
Dim rowchk As Range

Dim fromsheet
Dim fromrange
Dim fromfilepath
Dim tofilepath
Dim tofilename
Dim tosheet
Dim torange

Dim pastetypesheet
Dim foundcell
Dim pastetypejp
Dim pastetype

Dim Opnbook As Workbook
Dim fromOpnbook As Workbook
Dim toOpnbook As Workbook
Dim openflg
Dim savefilepath

'設定シート
setsheet = "自動セル転記"
pastetypesheet = "リスト）形式を選択して貼付"

'--------------------
'Main
'--------------------

'他に開いているブックがある場合は中止
For Each Opnbook In Workbooks
If Opnbook.FullName <> ThisWorkbook.FullName Then
MsgBox "安全のため、" & vbCrLf & "他のExcelファイルを全て閉じてから実行してください。"
Exit Sub
End If
Next Opnbook

MsgBox "転記を開始します。"

Application.ScreenUpdating = False '画面チラつき防止

'ログクリア
ThisWorkbook.Sheets(setsheet).Range("N21:N101").ClearContents

cntrow = 21
Do While cntrow < 100
With ThisWorkbook.Sheets(setsheet)

'転記設定の取得
fromfilepath = .Cells(cntrow, 2) & .Cells(cntrow, 3)
fromsheet = .Cells(cntrow, 4)
fromrange = .Cells(cntrow, 5)
tofilepath = .Cells(cntrow, 6) & .Cells(cntrow, 7)
tosheet = .Cells(cntrow, 8)
torange = .Cells(cntrow, 9)
tofilename = .Cells(cntrow, 7)
savefilepath = .Cells(cntrow, 10) & .Cells(cntrow, 11)
.Cells(cntrow, 14) = ""

'セル設定取得
pastetypejp = .Cells(cntrow, 12)
Set foundcell = Worksheets(pastetypesheet).Range("A:A").Find(pastetypejp)
If foundcell Is Nothing Then
pastetype = ""
Else
pastetype = Worksheets(pastetypesheet).Cells(foundcell.Row, 3)
End If

'--------------------
'エラー判定
'--------------------
'--EOF判定（セル範囲が全て空白）
Set rowchk = .Range(.Cells(cntrow, 1), Cells(cntrow, 12))
If WorksheetFunction.CountBlank(rowchk) = rowchk.Count Then
.Cells(cntrow, 14) = "OK）最終行です。"
Exit Do
End If

'--実行対象判定（セル範囲が全て空白）
Set rowchk = .Range(.Cells(cntrow, 1), Cells(cntrow, 1))
If WorksheetFunction.CountBlank(rowchk) = rowchk.Count Then
.Cells(cntrow, 14) = "OK）実行対象外によりスキップしました。"
GoTo Continue
End If

'--転記設定判定（セル範囲に空白が存在）
Set rowchk = .Range(.Cells(cntrow, 2), Cells(cntrow, 12))
If WorksheetFunction.CountBlank(rowchk) <> 0 Then
.Cells(cntrow, 14) = "ERR）設定エラーによりスキップしました。"
GoTo Continue
End If

On Error Resume Next
'--転記元ファイル判定
Open fromfilepath For Append As #1
Close #1
If Err.Number > 0 Then
.Cells(cntrow, 14) = "ERR）実行エラーによりスキップしました。（転記元ファイル）"
GoTo Continue
End If

'--転記先ファイル判定
Open tofilepath For Append As #1
Close #1
If Err.Number > 0 Then
.Cells(cntrow, 14) = "ERR）実行エラーによりスキップしました。（転記先ファイル）"
GoTo Continue
End If

'--保存先ファイル判定（別名保存の場合）
If tofilepath <> savefilepath Then
'ファイルが存在
If Dir(savefilepath) <> "" Then
.Cells(cntrow, 14) = "ERR）実行エラーによりスキップしました。（保存先ファイル）"
GoTo Continue
End If
End If

Application.DisplayAlerts = False 'アラート非表示

On Error GoTo 0
'--ファイル開く
Set fromOpnbook = Workbooks.Open(fromfilepath)
Set toOpnbook = Workbooks.Open(tofilepath)

'--セルをコピぺ
'--（参考）http://www.moug.net/tech/exvba/0050104.html
fromOpnbook.Sheets(fromsheet).Range(fromrange).Copy
toOpnbook.Sheets(tosheet).Range(torange).PasteSpecial Paste:=pastetype
toOpnbook.Sheets(tosheet).Cells(1, 1).Select

'--ファイル保存
If tofilepath = savefilepath Then
toOpnbook.Save
.Cells(cntrow, 14) = "OK）上書保存しました。"
Else
toOpnbook.SaveAs savefilepath
.Cells(cntrow, 14) = "OK）別名保存しました。"
End If

'--ファイル閉じる
fromOpnbook.Close
toOpnbook.Close

Application.DisplayAlerts = True 'アラート表示
End With

Continue:
cntrow = cntrow + 1
Loop

Application.ScreenUpdating = True
MsgBox "転記が完了しました。"

End Sub