| |
初めまして。
以下のマクロが2010で動かないのですが、原因がわかりません。
どなたか教えてください。よろしくお願いします！
Sub 貼り付け()
'
' データ貼り付け Macro
' アンケートから集計表にデータを貼り付けます。
'
'
On Error GoTo en
Application.ScreenUpdating = False
ph = ThisWorkbook.Path
Set fsFile = Application.FileSearch
With fsFile
.LookIn = ph
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
y = MsgBox(.FoundFiles.Count - 1 & "個のファイルのデータを集計表に貼り付けます", 4 + 48)
If y <> 6 Then End
For i = 1 To .FoundFiles.Count
fn = .FoundFiles(i)
If fn = ThisWorkbook.FullName Then GoTo ne
Workbooks.Open fn
fwc = Sheets.Count
fn = ActiveWorkbook.Name
ThisWorkbook.Activate
Sheets("投票結果").Select
Application.ScreenUpdating = False
'集計の最終行
rc = Range("A65536").End(xlUp).Row + 1
'集計の最終列
ec = Range("IV1").End(xlToLeft).Column
'項目名がおなじ場合貼り付け
For wc = 1 To fwc
For r = 1 To ec
For c = 1 To ec
With ThisWorkbook.Sheets("投票結果")
If .Cells(1, c) = Workbooks(fn).Sheets(wc).Cells(r, 1) Then
.Cells(rc, c) = Workbooks(fn).Sheets(wc).Cells(r, 2)
Else
End If
End With
Next c
Next r
'集計の最終行
rc = Range("A65536").End(xlUp).Row + 1
Next wc
Windows(fn).Close False
ne: Next i
End If
End With
Application.ScreenUpdating = True
Exit Sub
en: MsgBox "予期せぬエラーが発生しました。"
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
