Results of 1 - 1 of about 71 for ExecuteExcel4Macro 閉じた｜開いて｜開かず (0.012 sec.)
executeexcel4macro (140), 閉じた (629), 開いて (4904), 開かず (263)
- [[20190721131304]]
- #score: 14119
- @digest: b400fc14eda7046a23de938d8f47a1c5
- @id: 80274
- @mdate: 2019-07-23T10:11:01Z
- @size: 13091
- @type: text/plain
- #keywords: mytosht (27731), midasi (20194), 趣味 (18376), retu (9643), mydir (8225), properties (7714), wsname (6513), ゴル (6427), base (5422), mylist (4964), 計用 (4513), 強中 (3903), getfolder (3605), 各項 (3465), タフ (3314), 理番 (3040), ファ (2615), 計シ (2352), ァイ (2025), ォル (2004), ル名 (2000), 転記 (1742), 月1 (1732), ルダ (1716), 日) (1711), イル (1695), filesystemobject (1688), 2019 (1684), scripting (1600), object (1509), 集計 (1500), createobject (1410)
- 『フォルダ内にある全ファイルの特定セルの転記方法』（VBA勉強中）
「7月1日」というフォルダの中に、ファイル名の違うデータファイルが50個ある。 抽出したいのはD列のデータ。D列には◯が入っていたり空白の時もある。 D列のデータを別ファイルに転記し、各項目の合計を求めたい。 また、ファイル名も転記したい。 将来的には日次の集計の他に、月次の集計も取りたい。 どのようなプログラムを書くのが1番簡単でしょうか? フォルダ名:7月1日 ファイル名:123456, 324567, 345678, 654321..... C列 D列 趣味 当てはまる 1 ゴルフ ◯ 2 水泳 3 マラソン ◯ 4 野球 . . . 50 旅行 ◯ ＜ 使用 Excel:Excel2007、使用 OS:Windows7 ＞ ---- 簡単かはわかりませんが (1)Dir関数をつかって「7月1日」フォルダのうち「*.xls?」ファイルを片っ端から取得 (2)集計用の（ブックの集計用の）シートのC列最終行を求める (3)(1)のブックを開いて【データがあるシートを指定して】C〜D列をコピーする (4)(2)で求めた【セル】の1行下に(3)を貼付する (5)(2)〜(4)を繰り返す (6)作業用シートに、集計用の（ブックの集計用の）シートのC1〜C列最終行までをコピーする (7)(6)に対して重複の削除を使って、重複のない「項目」のリストを作成 (7)に対してSUMIF関数などを使って、「各項目」の集計を行う。 という感じでどうでしょうか? 個々の箇所で分からない場合は、現状のコードを示し、どこでどのようなエラーが出てしまうのか、エラーにならない場合でも、どのような結果になるはずが、どのような結果になってしまったのかを提示して頂くと、アドバイスできることがあるかもしれません。 ただ単に完成品がほしいという場合は、他の回答者さんをお待ちください。 （もこな2） 2019/07/21(日) 14:03 ---- もこな2さん、ありがとうございます。 私VBAは全くの初心者のため、完成品のが助かります。 他の回答を待つ事に致します。 （VBA勉強中） 2019/07/21(日) 14:06 ---- 1)各ファイルのシート名は共通、又は関連性があるか 2) >D列のデータを別ファイルに転記し、各項目の合計を求めたい. 具体的にわからない。 データが要件を満たしていればADO接続が簡単。 （seiya） 2019/07/21(日) 14:18 ---- 質問の意味の確認です ＞抽出したいのはD列のデータ。D列には◯が入っていたり空白の時もある。 ◯だけを抽出したいということ? ＞D列のデータを別ファイルに転記し、各項目の合計を求めたい。 数値が入っているわけではないので、合計はできないと思いますが ○の個数ということですか? ＞また、ファイル名も転記したい。 どこに・・ イメージされている完成予想図を提示されたほうが レスはつきやすいと思います。 それと肝心なことですが、各ファイルのシート数は1つですか? （渡辺ひかる） 2019/07/21(日) 14:31 ---- ○を抽出し、それが何個あるか合計を出したいです。 シート数は各1つ、シート名は同じです。 「7月1日」フォルダの中にあるファイル名も転記したいです。 素人の説明でわかりにくいかもしれませんが、下記のようなイメージです。 ファイル名 データ1 データ2 データ3 データ4・・ ------------------------------------------------------------------ 合計 No. 趣味 ------------------------------------------------------------------ 3 1 ゴルフ ○ ○ ○ 2 2 水泳 ○ ○ 1 3 マラソン ○ 1 4 野球 ○ 0 ・ ・ 0 ・ ・ 0 ・ ・ 4 50 旅行 ○ ○ ○ ○ （VBA勉強中） 2019/07/21(日) 19:22 ---- 各ファイルSheet1(仮の名前)の列項目に 趣味 当てはまる の2つの項目が必ず存在し○が入力されている趣味を抽出 集計シート(ActiveSheet)のC列に趣味のカテゴリーが既に列挙されていてD列から順に該当行に○を記入 ということで Sub test() Dim myDir As String, fn As String, x, y, t As Long, i As Long, txt As String Dim cn As Object, rs As Object, myList As Range Const wsName As String = "Sheet1" '<--------------要変更・シート名 With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then myDir = .SelectedItems(1) & "¥" End With If myDir = "" Then Exit Sub Set myList = Range("c1", Range("c" & Rows.Count).End(xlUp)) fn = Dir(myDir & "*.xls") If fn = "" Then Exit Sub Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") With cn .Provider = "Microsoft.Ace.OLEDB.12.0" .Properties("Extended Properties") = "Excel 12.0;HDR=Yes;" .Open myDir & fn End With t = 3 Range("d1", Cells.SpecialCells(11)).ClearContents Do While fn <> "" txt = IIf(t > 3, "In '" & myDir & fn & "' 'Excel 12.0;''HDR=Yes;IMEX=1;'''", "") rs.Open "Select `趣味`, `当てはまる` From `" & wsName & "$` " & txt & _ " Where `当てはまる` = '◯';", cn, 3, 3, 1 t = t + 1 Cells(1, t) = fn If rs.RecordCount Then x = rs.GetRows For i = 0 To UBound(x, 2) y = Application.Match(x(0, i), myList, 0) If IsNumeric(y) Then Cells(y, t).Value = "○" Next End If rs.Close fn = Dir Loop Set cn = Nothing: Set rs = Nothing End Sub （seiya） 2019/07/21(日) 20:34 ---- seiyaさん、ありがとうございます。 しかしながら、素人にはこのプログラムを書き換えて使う技術がありませんでした・・・ 趣味の欄は数行のセルが結合されている箇所もありますが、ずれませんでしょうか。 元ファイルは下記のような感じで、ファイル名も別の離れたセルに入っています。 ファイル名 データ1 No. 趣味 --------------- 1 ゴルフ ○ 2 水泳 3 マラソン ○ 4 野球 5 6 7 料理 ・ ・ 50 旅行 ○ （VBA勉強中） 2019/07/21(日) 21:10 ---- まず自分で書き換えることは考えずに、データの配置をきちんと正確に提示することから始めた方が 無駄な時間を過ごすことをなくすことができると思います。 まず各シートのレイアウトを正確に提示することをお勧めします。 どなたかが、あなたにも変更できるコードを書いてくれるかも知れません。 （seiya） 2019/07/21(日) 21:20 ---- 実際の元データのレイアウトは ファイル名（管理番号）がB2。 転記したい「○」の項目がD6からD50まであり、このRangeで1行ずつ抽出したいです。 この2つさえ転記できれば、あとは関数で○の数をカウントしようかと思っています。 （また、転記する時点でカウント数を入れられるなら尚良いとも思っています。） フォルダの中にマクロファイルを入れ、その階層にデータファイルを入れるフォルダを作成し、元データの場所をハイパーリンクと同じ要領で”C:¥マクロ¥元データ¥”などと指定すれば良いのでしょうか? （VBA勉強中） 2019/07/21(日) 21:39 ---- 管理番号がB2、データが6行目からで 趣味は C列 当てはまる はD列 出力先シートのA列にカウント,C列にC2から趣味のカテゴリーが列挙、 D列から出力、1行目にファイル名、該当行に○ という理解でよいですか? 管理番号はどこかに出力する必要がありますか? （seiya） 2019/07/21(日) 22:05 ---- 管理番号は19:22に書きました「データ1」「データ2」とかの部分に出力したいです。 （VBA勉強中） 2019/07/22(月) 06:53 ---- 下記コードを貼り付けたブックを同じフォルダに保存してから実行してください。 もし不具合が出た場合は何がどうしたのか、エラーが出た場合は行でどのようなエラーメッセージかを できるだけ詳細に伝えてください。 Sub test() Dim myDir As String, fn As String, x, y, t As Long, i As Long, txt As String Dim cn As Object, rs As Object, myList As Range Const wsName As String = "Sheet1" '<--------------要変更・シート名 myDir = ThisWorkbook.Path & "¥" Set myList = Range("c1", Range("c" & Rows.Count).End(xlUp)) fn = Dir(myDir & "*.xls") If fn = "" Then Exit Sub Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") With cn .Provider = "Microsoft.Ace.OLEDB.12.0" .Properties("Extended Properties") = "Excel 12.0;HDR=No;" .Open myDir & fn End With t = 3 Columns("d").Resize(, Application.Max(1, Cells.SpecialCells(11).Column - 3)).ClearContents Cells(1).CurrentRegion.Offset(1).Columns(1).ClearContents Do While fn <> "" If fn <> ThisWorkbook.Name Then txt = IIf(t > 3, "In '" & myDir & fn & "' 'Excel 12.0;''HDR=No;IMEX=1;'''", "") rs.Open "Select F1, F2 From `" & wsName & "$C6:D100` " & txt & _ " Where F2 = '◯';", cn, 3, 3, 1 t = t + 1 Cells(1, t) = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & wsName & "'!r2c2") If rs.RecordCount Then x = rs.GetRows For i = 0 To UBound(x, 2) y = Application.Match(x(0, i), myList, 0) If IsNumeric(y) Then Cells(y, t).Value = "○" Cells(y, 1).Value = Cells(y, 1).Value + 1 End If Next End If rs.Close End If fn = Dir Loop Set cn = Nothing: Set rs = Nothing End Sub （seiya） 2019/07/22(月) 08:44 ---- 単純にコピペで書いてみました お試しください なお、対象フォルダ内には、データファイルのみで、すべてのレイアウトが同じという前提です 集計シートのA列の数式は、ご自分で。 Sub test22() Dim myFso As Object ' Scripting.FileSystemObject Dim myFile As Object 'Scripting.File Dim myTosht As Worksheet Dim myFlg As Boolean Dim i As Long Const myPath As String = "C:¥Users" '対象フォルダ,適宜変更 Set myFso = CreateObject("Scripting.FileSystemObject") Set myTosht = ThisWorkbook.Worksheets(1) '集計シート myTosht.Cells.Clear myFlg = False i = 0 For Each myFile In myFso.GetFolder(myPath).Files With Workbooks.Open(myFile.Path) With .Worksheets(1) If myFlg = False Then '最初だけC列コピー .Range("C6:C50").Copy myTosht.Range("C6:C50") myFlg = True End If .Range("B2").Copy myTosht.Range("D2").Offset(, i) .Range("D6:D50").Copy myTosht.Range("D6:D50").Offset(, i) End With .Close False End With i = i + 1 Next End Sub （渡辺ひかる） 2019/07/22(月) 09:46 10:28 冗長分修正 ---- こんばんは ^^ なが〜いコードになってしまいました。。。 ^^; ＞＞C列がマージされている が気になるのですが。D列に○がある場合、D列がおなじ行分、マージされているか、C列のマージセルの 一番上の行位置と同じD列の行に○があれば良いのですが、それ以外はサポートしていません。もうひと工夫 必要ですが。。。この辺りはご本人様が調整されるのが一番ですね。。。A^_^; 集計用の（マクロ）ブックがあるフォルダのサブフォルダ 7月1日 にデータファイル（ブック）が ある。が、前程です。 Option Explicit Sub OneInstance01() '要、参照 Microsoft Scripting Runtime Dim Fd As String Dim Inf As Object Dim Fs As Object Dim D As Object Dim Wb As Workbook Dim Pcnt As Long Dim i As Long Dim y As Long Dim Base As Variant Dim rr As Range Dim Midasi() Dim Retu() Fd = ThisWorkbook.Path & "¥" & "7月1日¥" If Not Evaluate("=ISREF(TMP!A1)") Then Sheets.Add.Name = "TMP" Set Fs = New FileSystemObject Set D = CreateObject("Scripting.Dictionary") ReDim Midasi(1 To Fs.GetFolder(Fd).Files.Count) With Worksheets("TMP") .Cells.Delete For Each Inf In Fs.GetFolder(Fd).Files Set Wb = GetObject(Fd & Inf.Name) Pcnt = Pcnt + 1 Midasi(Pcnt) = Wb.Name With Wb.Worksheets(1) Set rr = .Range("C5").CurrentRegion Base = rr.Offset(1).Resize(rr.Rows.Count - 1, rr.Columns.Count) End With For i = 1 To UBound(Base, 1) If Base(i, 1) <> "" Then If Not D.Exists(Base(i, 1)) Then ReDim Retu(1 To Fs.GetFolder(Fd).Files.Count) Retu(Pcnt) = Base(i, 2) D.Add Base(i, 1), Retu Else Retu = D(Base(i, 1)) Retu(Pcnt) = Base(i, 2) D(Base(i, 1)) = Retu End If End If Next DoEvents Wb.Close False Set Wb = Nothing Erase Base Next y = 2 .Cells(1) = "○計" .Cells(1, 2) = "趣 味" .Cells(1, 3).Resize(, UBound(Midasi)) = Midasi For i = 0 To D.Count - 1 .Cells(y, 2) = D.Keys()(i) .Cells(y, 3).Resize(, UBound(Retu)) = D.Items()(i) .Cells(y, 1) = WorksheetFunction.CountA(.Cells(y, 3).Resize(, UBound(Retu))) y = y + 1 Next .UsedRange.EntireColumn.AutoFit End With Set D = Nothing Set Inf = Nothing Set Fs = Nothing End Sub 後処理追加 21:01 （隠居じーさん） 2019/07/22(月) 20:55 ---- 皆様、ありがとうございました。 書き換えたりして何とか完成させる事が出来ました! 感謝です。 （VBA勉強中） 2019/07/23(火) 19:11... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201907/20190721131304.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97056 documents and 608292 words.
訪問者：