エクセルマクロについての質問です。回答内容によって、500ポイント差し上げます。


条件:以下のファイル、フォルダが同一階層にあります。
・aaaa.xls
この中にはA列にID番号、B列に都道府県、C列に市町村、D列に建物名が記載されています。
・bbbb.xls
  この中にはA列に名称、B列にURLが記載されています。
・ccccフォルダ
  この中にはaaaa.xlsのA列のID番号の数だけフォルダが存在し、フォルダ名はID番号になります。
  ひとつのフォルダの中には以下のようにファイルが複数存在します。各フォルダの中にあるファイルの数はフォルダによって異なります。
    ex)c1.xls、c1.pdf、c1.doc(※ファイル名は同じで、拡張子のみがことなる)
※aaaa.xlsとbbbb.xlsは同じ行数分データが存在します。

これらのファイルに記載されている情報を以下の通り編集し、ひとつにまとめたい。
できれば操作は、aaaa.xlsファイル上で行いたい。
文字数のため、編集内容についてはコメントに記載します。

回答の条件
  • 1人10回まで
  • 登録:2009/01/23 17:02:56
  • 終了:2009/01/24 08:24:25

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/23 23:00:28

ポイント250pt

aaaa.xlsとbbbb.xlsにそれぞれ1行目からデータが入っているとして、

aaaa.xlsのSheet1にデータがあるとします。

aaaa.xlsとbbbb.xlsを開いた状態で、aaaa.xlsの新しいデータを開いて次のコードを

aaaa.xlsの標準モジュールにコピーして実行してください。


Sub Macro()
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim num As Long
    Dim wb As Worksheet
    Dim cPath As String
    Dim buf As String
    
    '特に指定が無かったのでbbbb.xlsのシートは1枚目にしています。
    Set wb = Workbooks("bbbb.xls").Worksheets(1)
    
    cPath = ThisWorkbook.Path & "\cccc\"
    
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    num = 1
    
    For i = 1 To lastRow
        Range("A" & i).Value = num
        num = num + 1
        Range("B" & i).Value = Sheet1.Range("A" & i).Value
        Range("C" & i).Value = Sheet1.Range("B" & i) & vbNewLine & Sheet1.Range("C" & i).Value
        If (StrConv(Right(wb.Range("B" & i).Value, 4), vbLowerCase) = ".pdf" Or _
            StrConv(Right(wb.Range("B" & i).Value, 4), vbLowerCase) = ".xls") Or _
            InStr(wb.Range("B" & i).Value, "true") > 0 Then
            Range("D" & i).Value = wb.Range("A" & i).Value
            Range("E" & i).Value = wb.Range("B" & i).Value
        Else
            Range("F" & i).Value = wb.Range("A" & i).Value
            Range("G" & i).Value = wb.Range("B" & i).Value
        End If
        buf = Dir(cPath & Sheet1.Range("A" & i).Value & "\*.*")
        j = 0
        While buf <> "" And j < 3
            j = j + 1
            Cells(i, j + 7).Value = buf
            buf = Dir()
        Wend
        Range("K" & i).Value = Sheet1.Range("A" & i).Value & Sheet1.Range("D" & i).Value
    Next i
End Sub
id:yuko0909

回答ありがとうございます。

先ほど、やってみましたが、「インデックスが有効範囲にありません」というエラーがでました。

デバックをしてみたところ、Set wb = Workbooks("bbbb.xls").Worksheets(1)の行が指定されてしまいました。

初歩的な質問で申し訳ないのですが、回答にある「aaaa.xlsの新しいデータを開いて」というのはどういう意味でしょうか?

もしかしたらその部分がきちんと解釈できていないからエラーがでるのかな・・・?

2009/01/24 00:41:44

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/23 23:00:28ここでベストアンサー

ポイント250pt

aaaa.xlsとbbbb.xlsにそれぞれ1行目からデータが入っているとして、

aaaa.xlsのSheet1にデータがあるとします。

aaaa.xlsとbbbb.xlsを開いた状態で、aaaa.xlsの新しいデータを開いて次のコードを

aaaa.xlsの標準モジュールにコピーして実行してください。


Sub Macro()
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim num As Long
    Dim wb As Worksheet
    Dim cPath As String
    Dim buf As String
    
    '特に指定が無かったのでbbbb.xlsのシートは1枚目にしています。
    Set wb = Workbooks("bbbb.xls").Worksheets(1)
    
    cPath = ThisWorkbook.Path & "\cccc\"
    
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    num = 1
    
    For i = 1 To lastRow
        Range("A" & i).Value = num
        num = num + 1
        Range("B" & i).Value = Sheet1.Range("A" & i).Value
        Range("C" & i).Value = Sheet1.Range("B" & i) & vbNewLine & Sheet1.Range("C" & i).Value
        If (StrConv(Right(wb.Range("B" & i).Value, 4), vbLowerCase) = ".pdf" Or _
            StrConv(Right(wb.Range("B" & i).Value, 4), vbLowerCase) = ".xls") Or _
            InStr(wb.Range("B" & i).Value, "true") > 0 Then
            Range("D" & i).Value = wb.Range("A" & i).Value
            Range("E" & i).Value = wb.Range("B" & i).Value
        Else
            Range("F" & i).Value = wb.Range("A" & i).Value
            Range("G" & i).Value = wb.Range("B" & i).Value
        End If
        buf = Dir(cPath & Sheet1.Range("A" & i).Value & "\*.*")
        j = 0
        While buf <> "" And j < 3
            j = j + 1
            Cells(i, j + 7).Value = buf
            buf = Dir()
        Wend
        Range("K" & i).Value = Sheet1.Range("A" & i).Value & Sheet1.Range("D" & i).Value
    Next i
End Sub
id:yuko0909

回答ありがとうございます。

先ほど、やってみましたが、「インデックスが有効範囲にありません」というエラーがでました。

デバックをしてみたところ、Set wb = Workbooks("bbbb.xls").Worksheets(1)の行が指定されてしまいました。

初歩的な質問で申し訳ないのですが、回答にある「aaaa.xlsの新しいデータを開いて」というのはどういう意味でしょうか?

もしかしたらその部分がきちんと解釈できていないからエラーがでるのかな・・・?

2009/01/24 00:41:44
id:ku__ra__ge No.2

ku__ra__ge回答回数118ベストアンサー獲得回数402009/01/23 23:56:56

ポイント250pt

以下のマクロをaaaa.xlsに置いて利用してみてください。

・bbbb.xls、ccccフォルダはaaaa.xlsと同じパスにあると想定して作成しました。

 定数値を変更することで調整が可能です。

・ccccフォルダのファイルは、最大3つまで(h,i,j列)であると想定して作成しました。

 4つ目以降のファイル名は無視されます。

Option Explicit

Enum ROW_NUM
    a = 0
    b
    c
    d
    e
    f
    g
    h
    i
    j
    k
End Enum

Const START_CELL = "a1"
Const FILE_BBBB = "bbbb.xls"
Const PATH_CCCC = "cccc"
Dim FSO As Object

' まとめた結果シートを作成する
Sub CreateSummary()
    ' 初期化
    ' ------------------------------------------------------------------------------------------
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' bbbb open
    ' ActiveWorkbookが変わらないように、後でActiveWorkbookを元に戻す
    Dim bookBackup As Workbook
    Set bookBackup = ActiveWorkbook
        Dim bookDataEx As Workbook
        Set bookDataEx = Workbooks.Open(ActiveWorkbook.Path & "\" & FILE_BBBB)
        
        Dim sheetDataEx As Worksheet
        Set sheetDataEx = bookDataEx.Sheets(1)
    bookBackup.Activate
    Set bookBackup = Nothing    ' もうこの変数は使わない
    
    ' aaaa のシートを得る
    Dim sheetData As Worksheet
    Set sheetData = ActiveSheet
    
    ' まとめた結果シートを空シートとして作成
    Dim sheetSummary As Worksheet
    Set sheetSummary = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
    ' まとめデータ作成処理
    ' ------------------------------------------------------------------------------------------
    Dim nSequence As Long
    nSequence = 1
    
    ' 1行ずつ下に移動しながら各行を処理
    Dim rngActDataCell As Range
    Set rngActDataCell = sheetData.Range(START_CELL)
    Do While Trim(rngActDataCell.Text) <> ""
        ' bbbb の処理行を取得
        Dim rngActDataExCell As Range
        Set rngActDataExCell = sheetDataEx.Cells(rngActDataCell.Row, 1)
        
        ' まとめた結果シート の処理行を取得
        Dim rngSummary As Range
        Set rngSummary = sheetSummary.Cells(rngActDataCell.Row, 1)
        
        ' 条件判定
        Dim bConditionFlg As Boolean
        bConditionFlg = IsCondition(rngActDataExCell.Offset(0, ROW_NUM.b))
        
        ' ファイル名取得
        Dim sFilenameList() As String
        sFilenameList = GetFilenameList(rngActDataCell.Offset(0, ROW_NUM.a))
        
        ' 書き出し
        rngSummary.Offset(0, ROW_NUM.a).Value = nSequence
        rngSummary.Offset(0, ROW_NUM.b).Value = rngActDataCell.Offset(0, ROW_NUM.a)
        rngSummary.Offset(0, ROW_NUM.c).Value = _
            "【都道府県名】" & vbLf & _
            rngActDataCell.Offset(0, ROW_NUM.b) & vbLf & _
            "【市町村名】" & vbLf & _
            rngActDataCell.Offset(0, ROW_NUM.c)
        If bConditionFlg = True Then
            rngSummary.Offset(0, ROW_NUM.d).Value = rngActDataExCell.Offset(0, ROW_NUM.a)
            rngSummary.Offset(0, ROW_NUM.e).Value = rngActDataExCell.Offset(0, ROW_NUM.b)
        Else
            rngSummary.Offset(0, ROW_NUM.f).Value = rngActDataExCell.Offset(0, ROW_NUM.a)
            rngSummary.Offset(0, ROW_NUM.g).Value = rngActDataExCell.Offset(0, ROW_NUM.b)
        End If
        rngSummary.Offset(0, ROW_NUM.h).Value = sFilenameList(0)
        rngSummary.Offset(0, ROW_NUM.i).Value = sFilenameList(1)
        rngSummary.Offset(0, ROW_NUM.j).Value = sFilenameList(2)
        rngSummary.Offset(0, ROW_NUM.k).Value = _
            rngActDataCell.Offset(0, ROW_NUM.a) & rngActDataCell.Offset(0, ROW_NUM.d)
        
        
        Set rngActDataCell = rngActDataCell.Offset(1, 0)  '次の行へ
        nSequence = nSequence + 1
    Loop
    
    ' 後始末
    ' ------------------------------------------------------------------------------------------
    ' bbbb close
    bookDataEx.Close SaveChanges:=False
    
    MsgBox "処理終了"
    
End Sub

' 条件1.URLの最後の拡張子が.pdf、.xlsである場合
' 条件2.URLに「true」という文字が含まれている場合
' ...trueを戻す。
Function IsCondition(sUrl As String) As Boolean
    Dim sUrlLowwer As String
    sUrlLowwer = LCase(sUrl)
    
    If Len(sUrlLowwer) < 4 Then
        IsCondition = False
        Exit Function
    End If
    If Right(sUrlLowwer, 4) = ".pdf" Then
        IsCondition = True
        Exit Function
    End If
    If Right(sUrlLowwer, 4) = ".xls" Then
        IsCondition = True
        Exit Function
    End If
    If InStr(sUrlLowwer, "true") > 0 Then
        IsCondition = True
        Exit Function
    End If
    
    IsCondition = False
End Function

' ccccフォルダのファイル取得
Function GetFilenameList(sId As String) As String()
    Dim sList(2) As String
    
    Dim sTargetFolder As String
    sTargetFolder = ActiveWorkbook.Path & "\" & PATH_CCCC & "\" & sId
    
    If FSO.FolderExists(sTargetFolder) = False Then
        GetFilenameList = sList
        Exit Function
    End If
    
    Dim oFolder As Object
    Set oFolder = FSO.GetFolder(sTargetFolder)
    
    Dim nIdx As Integer
    nIdx = 0
    Dim oFile As Object
    For Each oFile In oFolder.Files
        sList(nIdx) = oFile.Name
        nIdx = nIdx + 1
        If nIdx > UBound(sList) Then Exit For
    Next
    
    GetFilenameList = sList
End Function
id:yuko0909

回答ありがとうございます。

このマクロを実行したところ、bbbb.xlsが見つかりませんと言われてしまいました…。

いまのフォルダ構成ですが、デスクトップ上にテストフォルダを作成し、その中にaaaa.xlsとbbbb.xls、ccccフォルダがあります。

なにか解決方法はありますか?

お手数をおかけしますが、回答お願いします。

2009/01/24 00:47:55
  • id:yuko0909
    編集内容についてです

    編集内容
      ・A列には昇順になるよう番号を振っていく。
      ・B列にはaaaa.xlsのA列の値を出力
      ・C列には【都道府県名】(改行)
           aaaa.xlsのB列の値(改行)
           【市町村名】(改行)
           aaaa.xlsのC列の値を出力
      ・D列にはbbbb.xlsのB列の値が以下の条件のどちらかを満たすとき、bbbb.xlsのA列の値を出力する
         条件1.URLの最後の拡張子が.pdf、.xlsである場合
         条件2.URLに「true」という文字が含まれている場合
      ・E列にはbbbb.xlsのB列の値が上記の条件のどちらかをみたすとき、bbbb.xlsのB列の値を出力する
      ・F列には、bbbb.xlsが上記の条件のどちらにも当てはまらない場合のみ、bbbb.xlsのA列の値を出力する
      ・G列には、bbbb.xlsが上記の条件のどちらにも当てはまらない場合のみ、bbbb.xlsのB列の値を出力する
      ・H列~J列には、ccccフォルダ内にあるファイルのファイル名を出力する。
      ・K列にはaaaa.xlsのA列の値とD列の値をつなげたものを出力する
         例)aaaa.xlsのA列が"a0111"、D列が"東京タワー"の場合
           出力>a0111東京タワー
     ※この操作はaaaa.xlsにデータが存在する限り繰り返す。
  • id:SALINGER
    ちょっと勘違い。18行目
    >>
    Range("C" & i).Value = Sheet1.Range("B" & i) & vbNewLine & Sheet1.Range("C" & i).Value
    <<

    >>
    Range("C" & i).Value = "【都道府県名】" & vbNewLine & Sheet1.Range("B" & i) & vbNewLine & _
    "【市町村名】" & vbNewLine & Sheet1.Range("C" & i).Value
    <<
    でした
  • id:SALINGER
    bbbb.xlsをあらかじめExcelで開いていないせいだと思われます。
    実行するときはaaaa.xlsで、データを作成したいシート(例えばSheet2)をアクティブにして実行してみてください。

    もしも、Windowsで拡張子を表示しない設定になっていたらコード中の
    bbbb.xls → bbbb
    のように拡張子の部分を取ってください。
  • id:ku__ra__ge
    > このマクロを実行したところ、bbbb.xlsが見つかりませんと言われてしまいました…。
    > いまのフォルダ構成ですが、デスクトップ上にテストフォルダを作成し、その中にaaaa.xlsとbbbb.xls、ccccフォルダがあります。
    bbbb.xlsファイルのある場所は Excelで現在開いているファイルのパスを元に求めているので、別のxlsファイルを開いているとパスが正しく取得できないかもしれません。aaaa.xlsのみを開いてID番号、都道府県、市町村、建物名のデータがあるシートを選択した状態でマクロを実行してみてください。
    私の動作確認した環境も、デスクトップ上のテストフォルダにaaaa.xls,bbbb.xls,ccccフォルダを置いたものなので、ファイル構成は問題ないと思います。
  • id:yuko0909
    >SALINGER さん

    すみません。エクセルのバージョンを2003でやったらできました!!
    はじめ2007で確認していましたので・・・。実際にこのマクロを使用するのは2003ですのでこのマクロで十分対応されていると思います。
    ほんとうにありがとうございました。
  • id:yuko0909
    >ku__ra__geさん

    すみません。エクセルのバージョンを2003でやったらできました!!
    はじめ2007で確認していましたので・・・。実際にこのマクロを使用するのは2003ですのでこのマクロで十分対応されていると思います。
    ほんとうにありがとうございました。

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

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

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

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