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

エクセルマクロについての質問です。回答内容によって、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ファイル上で行いたい。
文字数のため、編集内容についてはコメントに記載します。


●質問者: yuko0909
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:DOC EX PDF URL xls
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●250ポイント ベストアンサー

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
◎質問者からの返答

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

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

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

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

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


2 ● ku__ra__ge
●250ポイント

以下のマクロを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
◎質問者からの返答

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

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

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

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

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

関連質問


●質問をもっと探す●



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