人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

【excel VBA】excel 2003です。あるフォルダに、図のリンク貼り付けを利用したexcelのファイルがいくつもあります。その全てのファイル、全てのシートのリンク元の一覧(フルパスのファイル名・シート名・リンク先のセル(C1R1表記))のexcelファイルを作る、excel マクロを教えてください。シートにはリンク貼り付けがある場合とない場合があります。



●質問者: nankichi
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:Excel VBA けが セル パス
○ 状態 :キャンセル
└ 回答数 : 1/1件

▽最新の回答へ

1 ● ardarim

こんな感じでどうでしょうか。

SearchAllFiles() の引数でフォルダ名を指定してください。


手元の環境では動いていますが...

Option Explicit
Option Base 0

Sub test()

 Call SearchAllFiles("c:\temp")

End Sub

Sub SearchAllFiles(SearchPath As String)

 Dim result() As String
 Dim i As Integer, j As Integer
 Dim n As Integer
 Dim r As Integer
 Dim tmp As String
 Dim xlsFiles() As String
 Dim wb As Workbook
 Dim sh As Worksheet
 Dim ub As Integer
 
 If Right$(SearchPath, 1) <> "\" Then
 SearchPath = SearchPath & "\"
 End If
 
 i = 0
 tmp = Dir(SearchPath & "*.xls")
 Do While tmp <> ""
 ReDim Preserve xlsFiles(i + 1)
 xlsFiles(i) = SearchPath & tmp
 i = i + 1
 tmp = Dir()
 Loop
 n = i
 
 With ThisWorkbook.Worksheets(1)
 .Cells.Clear
 .Cells(1, 1).Value = "ファイル名"
 .Cells(1, 2).Value = "シート名"
 .Cells(1, 3).Value = "リンク先ファイル名"
 .Cells(1, 4).Value = "リンク先シート名"
 .Cells(1, 5).Value = "リンク先セル範囲"
 End With
 
 
 r = 2
 For i = 0 To n - 1
 Application.StatusBar = "opening " & xlsFiles(i) & "..."
 Application.ScreenUpdating = False
 Set wb = Workbooks.Open(xlsFiles(i), 0, True)
 For Each sh In wb.Worksheets
 ub = GetLinkRecords(wb, sh, result)
 For j = 0 To ub - 1 Step 3
 With ThisWorkbook.Worksheets(1)
 .Cells(r, 1).Value = xlsFiles(i)
 .Cells(r, 2).Value = sh.Name
 .Cells(r, 3).Value = result(j)
 .Cells(r, 4).Value = result(j + 1)
 .Cells(r, 5).Value = result(j + 2)
 End With
 r = r + 1
 Next j
 Next sh
 wb.Close False
 Application.ScreenUpdating = True
 Next i
 
 Application.StatusBar = False
 
End Sub

Function GetLinkRecords(wb As Workbook, sh As Worksheet, result() As String) As Integer

 Dim chobj As ChartObject
 Dim s As Series
 Dim ls As Variant
 Dim st As Integer
 Dim fn As String
 Dim f As String
 Dim i As Integer
 
 i = 0
 ReDim result(0)
 
 For Each chobj In sh.ChartObjects
 For Each s In chobj.Chart.SeriesCollection
 For Each ls In wb.LinkSources(xlExcelLinks)
 f = s.FormulaR1C1
 fn = GetFileName(ls)
 st = InStr(f, "[" & fn & "]")
 If st > 0 Then
 st = st + Len(fn) + 2
 ReDim Preserve result(i + 3)
 result(i) = ls
 result(i + 2) = Mid(f, st, InStr(st, f, ",") - st)
 result(i + 1) = Left$(result(i + 2), InStr(result(i + 2), "!") - 1)
 result(i + 2) = Right$(result(i + 2), Len(result(i + 2)) - Len(result(i + 1)) - 1)
 If Right$(result(i + 1), 1) = "'" Then
 result(i + 1) = Left$(result(i + 1), Len(result(i + 1)) - 1)
 End If
 i = i + 3
 End If
 Next ls
 Next s
 Next chobj
 
 GetLinkRecords = i
 
End Function

Function GetFileName(ByVal FullPathName As String) As String

 Dim objFSO As Object
 Dim objFile As Object
 
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objFile = objFSO.GetFile(FullPathName)
 
 GetFileName = objFSO.GetFileName(objFile)

 Set objFile = Nothing
 Set objFSO = Nothing

End Function

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ