Results of 1 - 1 of about 71 for ExecuteExcel4Macro 閉じた｜開いて｜開かず (0.012 sec.)
executeexcel4macro (140), 閉じた (629), 開いて (4904), 開かず (263)
- [[20110627101600]]
- #score: 14119
- @digest: 11c4c390936fe0b200644aed5e9175d9
- @id: 55045
- @mdate: 2011-06-27T04:58:28Z
- @size: 7794
- @type: text/plain
- #keywords: objtarget (29523), mysheets (26586), mypool (24234), stfolder (22494), mylist (22340), searchfiles (21079), getsheetname (18688), adocn (16454), adors (15273), ダ形 (13533), filelist (12488), mycell (10855), objfso (8024), shname (5676), 定", (5219), mydir (5140), mybook (5093), 宜変 (4479), 記シ (4259), myfolder (4178), 精査 (4030), myfilename (3826), collection (3274), myfile (3268), ルc2 (3260), subfolders (3103), 適宜 (2772), getfolder (2703), mypath (2450), executeexcel4macro (2389), 限定 (2347), 覧表 (2113)
- 『ファイルから特定のセルの一覧表』（あんころもち）
複数の同フォームファイルから特定のセルデータを抽出したいのですが 何か良い方法は無いでしょうか。 フォルダ形態は年-月-日 となっておりファイル名はばらばらです。 例 『2011』 『06』 『03.xls』 『04そのいち.xls』 みたいな感じです。 その中でシート名が『限定』となっているシートのセルC21とG24と シート名が『特定』となっているシートのセルC20の一覧表を作成したいのですが、 一つずつファイルを開くのが面倒なんでよい方法が有りましたら教えてください。 ファイル数は5年分で約1500ほど有ります。 Excel2003です。 よろしくお願いします。 ---- まず、関数というか、シート上の設定で? それともVBAでもいい? 次に、「一つずつファイルを開くのが面倒」、これは人間が1500ファイル開くと「面倒」だけど VBAにやらせれば、別に「面倒」ではないね。開いていることを気づかせずに処理すればいいのか それとも、「絶対に開かないで処理したい」のか、そこは、どうですか? もう1つ追加質問 フォルダ内の各ブックには、「必ず」『限定』シートと『特定』シートがある? それとも、1つしかない、あるいは全くないものもある? ぶらっと立ち寄り ---- ありがとうございます。 手段は何でもいいです。 その一覧表を作成し、ファイルの精査をしたいので マクロ?VBA?ハイパーリンク?何らかの手法で一覧表が作成できたら ありがたいのです。 VBAで一覧表作成の時間が掛かっても関数でそのファイルが重たくなっても 一覧表が作成でき精査が終われば消します。 ブックにはそのシートが無いものも混じっています。 よろしくお願いします。（あんころもち） ---- > フォルダ形態は年-月-日 となっておりファイル名はばらばらです。 > 例 『2011』 > 『06』 > 『03.xls』 > 『04そのいち.xls』 みたいな感じです。 この説明がわかりずらいので、サブフォルダ全てにループしています。 Sub test() Dim myDir As String, myList myDir = "ここに親フォルダのパス" myList = SearchFiles(myDir, "*.xls*") If IsArray(myList) Then GetInfo myList Else MsgBox "No files found" End If End Sub Function SearchFiles(myDir As String, myFileName As String) As Variant Dim fso As Object, myFolder As Object, myFile As Object Dim myList() As String, n As Long Set fso = CreateObject("Scripting.FileSystemObject") For Each myFile In fso.GetFolder(myDir).Files If (Not myFile.Name Like "‾$*") * (myFile.Name <> ThisWorkbook.Name) * (myFile.Name Like myFileName) Then n = n + 1 ReDim Preserve myList(1 To 2, 1 To n) myList(1, n) = myDir myList(2, n) = myFile.Name End If Next For Each myFolder In fso.GetFolder(myDir).SubFolders SearchFiles myDir & "¥" & myFolder.Name, myFileName Next SearchFiles = IIf(n > 0, myList, 0) End Function Private Sub GetInfo(myList) Dim i As Long, wsName As String, t As Long, x, mySheets, e mySheets = Array(Array("限定", "R21C3", "R24C7"), Array("特定", "r20c3")) With ThisWorkbook.Sheets(1) .Cells.Clear .Cells(1, 1).Resize(, 4).Value = _ Array("ファイル パス", mySheets(0)(0) & "!C21", mySheets(0)(0) & "!G24", mySheets(1)(0) & "!C20") t = 1 For i = 1 To UBound(myList, 2) x = ExecuteExcel4Macro("'" & myList(1, i) & "¥[" & myList(2, i) & "]" & w(0)(0) & "'!R1C1") y = ExecuteExcel4Macro("'" & myList(1, i) & "¥[" & myList(2, i) & "]" & w(1)(0) & "'!R1C1") If (Not IsError(x)) + (Not IsError(y)) Then t = t + 1 .Cells(t, 1).Value = myList(1, i) & "¥" & myList(2, i) If Not IsError(x) Then .Cells(t, 2).Resize(, 2).Formula = _ Array("='" & myList(1, i) & "¥[" & myList(2, i) & "]" & w(0)(0) & "'!" & w(0)(1), _ "='" & myList(1, i) & "¥[" & myList(2, i) & "]" & w(0)(0) & "'!" & w(0)(2)) End If If Not IsError(y) Then .Cells(t, 4).Formula = "='" & myList(1, i) & "¥[" & myList(2, i) & "]" & w(1)(0) & "'!" & w(1)(1) End If End If Next .Range("a1:d1").EntireColumn.AutoFit End With End Sub (seiya) 抽出時の不具合を修正 13:58 ---- seiyaさんとはちょっと方式が違うところもあるのでコードをアップ。 サブプロシジャのgetSheetNameについてはネットに掲載された、あれやこれやを踏まえているので もしかしたら、著作権侵害の可能性もあるけど・・・・ seiyaさんと同じく、ブックを開かずに処理。参照するフォルダパスや転記シート情報については 実態に合わせてチューニングしてね。 なお、ファイルを開かないでファイル名を抽出するには、いろんな方法があるけど、ここでは、コードが簡単になるので それらの中で「一番遅い」FSOを使っている。 Sub Sample() Dim myPool As Collection Dim wk As Variant Dim stFolder As String Dim objFSO As Object Dim shV As Variant Dim shN As Variant Dim shX As Variant Dim myCell As Range Dim myPath As String Dim myBook As String With ThisWorkbook.Sheets("Sheet1") '転記シート 適宜変更 .Cells.Clear Set myCell = .Range("A1") '転記開始セル 適宜変更 End With Set objFSO = CreateObject("Scripting.FileSystemObject") Set myPool = New Collection stFolder = ThisWorkbook.Path & "¥2011¥" '開始フォルダ 適宜変更 Call FileList(objFSO.GetFolder(stFolder), myPool) For Each wk In myPool wk = Split(wk, vbTab) myPath = wk(0) myBook = wk(1) shV = getSheetName(myPath & "¥" & myBook) For Each shN In Array("限定", "特定") shX = Application.Match(shN, shV, 0) If IsNumeric(shX) Then Select Case shN Case "特定" myCell.Value = "='" & myPath & "¥[" & myBook & "]" & shN & "'!C20" Case "限定" 'C21,C24 myCell.Value = "='" & myPath & "¥[" & myBook & "]" & shN & "'!C21" Set myCell = myCell.Offset(1) myCell.Value = "='" & myPath & "¥[" & myBook & "]" & shN & "'!C24" End Select Set myCell = myCell.Offset(1) End If Next Next With ThisWorkbook.Sheets("Sheet1") '転記シート 適宜変更 '.Cells.Value = .Cells.Value '値に変更 End With Set objFSO = Nothing Set myPool = Nothing End Sub Private Sub FileList(objFD As Object, fPool As Collection) Dim objTarget As Object Dim objSFD As Object 'ファイル名を列挙 For Each objTarget In objFD.Files fPool.Add objTarget.parentfolder & vbTab & objTarget.Name Next 'サブフォルダを検索 For Each objSFD In objFD.subfolders Call FileList(objSFD, fPool) Next End Sub Private Function getSheetName(wbName As String) As Variant Const adSchemaTables As Long = 20 Dim adoCn As Object Dim adoRs As Object Dim shName As String Dim chk As String Dim j As Long Dim x() j = 1 On Error Resume Next Set adoCn = CreateObject("ADODB.Connection") adoCn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & wbName & ";" & _ "Extended Properties=Excel 8.0;") Set adoRs = adoCn.OpenSchema(adSchemaTables) Do Until adoRs.EOF If adoRs Is Nothing Then Exit Do shName = adoRs.Fields("TABLE_NAME").Value chk = Right$(shName, 1) If chk Like "$" Or chk Like "'" Then ReDim Preserve x(1 To j) x(j) = Left$(shName, Len(shName) - 1) j = j + 1 End If adoRs.MoveNext Loop adoRs.Close Set adoRs = Nothing adoCn.Close Set adoCn = Nothing getSheetName = x End Function ぶらっと立ち寄り... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201106/20110627101600.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97056 documents and 608292 words.
訪問者：