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


回答の条件
  • 1人5回まで
  • 登録:2007/03/13 14:23:19
  • 終了:2007/03/20 14:25:03

回答(1件)

id:ardarim No.1

ardarim回答回数897ベストアンサー獲得回数1452007/03/17 22:46:18

ポイント10pt

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

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

  • id:llusall
    私には重いので正式回答は控えさせていただきます。
    OLEObjects コレクションを回すことにより、リンクファイルのパスを取得できそうですね。
    以下、サンプル。

      Dim ws As Worksheet
      
      For Each ws In Worksheets
        Debug.Print "====================================================="
        Debug.Print "シート名:" & ws.Name

        Dim oleo As OLEObject
        For Each oleo In ws.OLEObjects
          Debug.Print "----------------------------------"
          Debug.Print "セル:" & oleo.TopLeftCell.Address(True, True, xlR1C1)
          Debug.Print "リンクファイル名:" & oleo.SourceName
        Next
      Next

    あと実装しなければならないのは、
    ・指定フォルダのエクセルファイル名を列挙
    ・1つ1つ開いて、上記処理をする。
    ・Debug.Printでなく、シート(セル)に書き出す。
    ・リンクファイル名は適宜整形する。
    くらいでしょうか。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません