Results of 1 - 1 of about 295 for cell filename (0.001 sec.)
cell (1170), filename (1984)
- [[20170223003629]]
- #score: 11157
- @digest: c90ffa6bea82d3a086b6c18e859d902c
- @id: 72777
- @mdate: 2017-02-24T12:49:01Z
- @size: 17071
- @type: text/plain
- #keywords: recursex (67484), summary (61787), mastertracker (54242), projections (54242), mysubfolder (35939), sfilename (34451), erow (31636), repeattrackingprocess (30483), recurse (27862), multiple (19948), wbk (13549), spath (9762), folder (7800), subfolders (7758), master (7439), a17 (5859), myfolder (5571), 元ブ (5330), files (4153), sht (3720), ブッ (3323), filename (3179), xlsm (2761), function (2483), tmp (2270), filesystemobject (2253), path (2196), 2017 (1745), 抽出 (1700), ック (1654), 元デ (1563), シー (1448)
- 『複数ブックのデータをまとめるマクロのデータが重なってしまう』（のんさびぃ）
長年引き継いで使われている文書中で、複数ブック（20‾30ブック）のデータをまとめるというマクロがあるのですが、データが重なって抽出されてしまい、2行しか表示されません。 各ブックがちゃんと開かれるという動作は確認できますし、エラーも出ません。 どこを直せばデータが重ならないようになるのでしょうか? コードは以下になります。 'This function is used to track all the excel sheets and store them in the Master file Sub updateTrackingSheet() 'Declaring Variables Dim wbk As Workbook Dim fileName As String Dim myFile As String Dim Path As String Dim erow Dim sht As Worksheet Dim LastRow As Long Dim LastColumn As Long Dim StartCell As Range Dim wsheetRange As Range Dim dRange As Range Dim msg As String Application.DisplayAlerts = False Application.AskToUpdateLinks = False 'Set Path Here Path = Application.ActiveWorkbook.Path & "¥" fileName = Dir(Path & "*.xlsm") Do While Len(fileName) > 0 If (fileName = "MasterTracker Projections.xlsm") Then Exit Do End If Set wbk = Workbooks.Open(Path & fileName) 'Setting Last Saved Date in cell B41 Range("A17:L17").Copy wbk.Close erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'Pasting values from individual excel files into Master erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row ActiveSheet.Paste Destination:=Worksheets("Summary").Range(Cells(erow, 1), Cells(erow, 12)) Columns("A:L").Select Selection.EntireColumn.AutoFit fileName = Dir Loop 'Repeating Procedure for files in subfolder Call Recurse(Path) 'Msg on Completion msg = MsgBox("Tracking Sheet Updated Successfully", vbOKOnly) End Sub 'Function to perform operation in multiple subfolders Public Function Recurse(sPath As String) As String Dim fso As New FileSystemObject Dim myFolder As Folder Dim mySubFolder As Folder Dim wbk As Workbook Dim sFilename As String Dim erow Dim sht As Worksheet Dim LastRow As Long Dim LastColumn As Long Dim StartCell As Range Dim wsheetRange As Range Application.DisplayAlerts = False Application.AskToUpdateLinks = False Set myFolder = fso.GetFolder(sPath) For Each mySubFolder In myFolder.SubFolders Call repeatTrackingProcess(mySubFolder.Path) Recurse = Recurse(mySubFolder.Path) Next End Function 'Repeat Function for multiple Files Function repeatTrackingProcess(ByVal s As String) Dim fso As New FileSystemObject Dim myFolder As Folder Dim myFile As File Dim mySubFolder As Folder Dim wbk As Workbook Dim sFilename As String Dim erow Dim sPath As String Dim sht As Worksheet Dim LastRow As Long Dim LastColumn As Long Dim StartCell As Range Dim wsheetRange As Range Application.DisplayAlerts = False Application.AskToUpdateLinks = False Set mySubFolder = fso.GetFolder(s) sPath = (mySubFolder & "¥") sFilename = Dir(sPath & "*.xlsm") Do While Len(sFilename) > 0 If sFilename = "MasterTracker Projections.xlsm" Then Exit Do End If Set wbk = Workbooks.Open(sPath & sFilename) 'Setting Last Saved Date in cell B41 Range("A17:L17").Copy wbk.Close erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'Pasting values from individual excel files into Master ActiveSheet.Paste Destination:=Worksheets("Summary").Range(Cells(erow, 1), Cells(erow, 12)) Columns("A:L").Select Selection.EntireColumn.AutoFit sFilename = Dir Loop End Function どうぞよろしくお願いいたします。 ＜ 使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- とりあえず、 'Repeat Function for multiple Files Function repeatTrackingProcess(ByVal s As String) となってしまってますので、Function以降を改行して次のようにしてください。 'Repeat Function for multiple Files Function repeatTrackingProcess(ByVal s As String) あと、…、サンプルデータを示さないと、こちらで再現できません。コードを見る気になりません。 （!!!） 2017/02/23(木) 02:56 ---- 早速のご返信ありがとうございます。肝心のデータですよね、大変失礼しました。 A B C D E F G H I J K L Dept Text Svc Amend Bud Svc Proj Bal Opr Amend Bud Opr Proj Bal Total Amend Budget Total Proj Bal Filled Full-time Vac Full-Time Temp Pos Filled Part-Time COM TtlExp 1000000 150000 330000 380000 245000 350000 160 30 0 3 . . . POL TtlExp 1300000 180000 300000 350000 150000 500000 280 50 8 15 元データの複数ブックのA17‾L17に同じ形のデータがあり、それをコピー先にまとめるようになっています。 各ブックから一行抽出なので、ブック分（20から30）の行数ができるはずなのです。 これでわかりますでしょうか?よろしくお願いします。 （のんさびぃ） 2017/02/23(木) 03:36 ---- 質問テーマの前に。 フォルダからブックをピックアップするところで、 If (fileName = "MasterTracker Projections.xlsm") Then Exit Do End If こんなところがありますね。 おそらく、DIRで取り出されたブックが、このマクロブックなら対象外にするという意図でしょうけど、 Exit Do ですから、このブックが見つかれば、それで、ループが終わり、Call Recurse(Path) に行ってしまいます。 いいのですか? それと、ブックが、自分自身かどうかを判定しているなら、ブック名をきくのは、将来ブック名が変更になった際に 問題が出てきます。 If fileName = ThisWorkbook.Name Then としておくのが常道です。 今回の場合は 自ブックなら処理せずスキップですから Do While Len(sFilename) > 0 If fileName <> Thisworkbook.Name Then ファイルを開いて処理して閉じ、コピーしてペーストするAutoFitまでの現行コード End If fileName = Dir Loop こんな構成になるかと。 で、質問のテーマですが、コメントをするために、シートの構成を教えてください。 updateTrackingSheet が参照しているシートが3つあります。 1.まず、フォルダから抽出したブックを開いたときに「たまたま」アクティブになっているシート。 もし、複数シートがあるブックなら、どのシートが対象になるかわからない、あぶなっかしいコードですが Range("A17:L17").Copy ここで参照しています。 2.次に、転記すべき行番号を取得する目的のコードだと思いますが erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row （同じものが2行書かれているのは1行消し忘れ?） フォルダから取り出して開いたブックを閉じた後の実行ですから、おそらく、Sheet1 は マクロブックのシートだと 思いますが、Sheet1 という指定、ちゃんと理解してお使いですよね? これは シート名 ではなく、シートのCodeName(オブジェクト名）です。 VBE画面の左上のプロジェクトエクスプローラを見たときに Sheet1(xxxx) Sheet2(yyyy) となっている左側がCodeName です。右の かっこの中はシート名です。 いずれにしても、この CodeNmae が Sheet1 というシートの A列データ最終セルの次のセルの行番号を取得しています。 3.実際にペーストするシート。 ActiveSheet.Paste Destination:=Worksheets("Summary").Range(Cells(erow, 1), Cells(erow, 12)) SHeet1 の状態によって取得した erow を使って "Summary" というシート名のシートにペーストしています。 この "Summary" が Sheet1 と同じならいいのですが、そうなんですか? また 同じなら、2.の取得コードも シート名 "Summary" を使うべきです。（ないしは、3.のコードも SHeet1 を使う） ★もし Sheet1 と "Summary" が 違うシートであれば、すべてが "Summary" シートの同じ行に上書きされてしまう こういうコードになっていますね。 （ β） 2017/02/23(木) 08:16 ---- 一番初めに書いたのですが、長年受け継がれて使われているもので、途中で誰かが何か （特にシート名など）を変えたりしているのかなどまったく不明でして、すみません・・・ しかもシート構成の説明まで抜けているとは、本当に申し訳ありません。 このマクロが書かれている文書がMaster.xlsmで、"Summary" "Sheet2" "Sheet3"の3シートがあり、"Summary"以外はブランクです。 Master.xlsmの保存されているフォルダ内にサブフォルダ（フォルダ名はTrack）があり、その中に現在23ブック入っていて、 それぞれ複数シートある（数や名前はバラバラ）のですが、全ブックに共通して"Summary"というシートがあり、 そのSummaryシートのA17:L17が抽出されるべきデータです。 つまり元データのほうも"Summary"シートで、ペースト先も"Summary"シートとなっています。 確かに、βさんのご指摘通り、たまたまアクティブになっているシートのデータが返されているらしき現象もありました。 引き続きどうぞよろしくお願いいたします。 （のんさびぃ） 2017/02/23(木) 13:26 ---- 想像しながら書いているところが少なくないので、不具合あれば指摘願います。 ・サブフォルダからの抽出のための再帰処理ですが、同じ処理のプロシジャの2段構えになっていましたので ふつうのFSOによる再帰処理の記述にしてあります。 ・MasterTracker Projections.xlsm の除外が必要なのかどうかわかりませんけど、残してあります。 ・対象ブックの判定を If LCase(tmp(UBound(tmp))) Like "xls*" Then にしてあります。 つまり、xlsxブックでも抽出するというロジックにしています。 そうではなく xlsm ブックのみ対象ということなら、これを If LCase(tmp(UBound(tmp))) = "xlsm" Then に変えてください。 Sub Sample() Dim fso As FileSystemObject Dim sht As Worksheet Application.AskToUpdateLinks = False Application.ScreenUpdating = False Set sht = ThisWorkbook.Sheets("Summary") Set fso = New FileSystemObject Call RecurseX(sht, fso.GetFolder(Application.ActiveWorkbook.path & "¥")) sht.Columns("A:L").AutoFit Application.ScreenUpdating = True 'Msg on Completion MsgBox "Tracking Sheet Updated Successfully" End Sub Private Sub RecurseX(sht As Worksheet, fd As Folder) Dim ff As File Dim sd As Folder Dim erow As Long Dim wbk As Workbook Dim shf As Worksheet Dim tmp As Variant For Each ff In fd.Files If ff.Name <> "MasterTracker Projections.xlsm" Then tmp = Split(ff.Name, ".") If LCase(tmp(UBound(tmp))) Like "xls*" Then If Not ff.Name Like "*" & ThisWorkbook.Name Then Set wbk = Workbooks.Open(ff.path) On Error Resume Next Set shf = wbk.Worksheets("Summary") On Error GoTo 0 If shf Is Nothing Then MsgBox wbk.Name & "には、Summaryシートがないので抽出をスキップします" Else shf.Range("A17:L17").Copy sht.Range("A" & Rows.Count).End(xlUp).Offset(1) End If wbk.Close False End If End If End If Next For Each sd In fd.SubFolders Call RecurseX(sht, sd) Next End Sub （ β） 2017/02/23(木) 16:34 ---- βさん、どうもありがとうございました。 上記コードを試したところ、抽出されたのは5行だけで、値がすべて=#REF!という表示になりました。 元データにも問題があるのですかね? 引き続き何かわかりましたら、よろしくお願いします。 （のんさびぃ） 2017/02/23(木) 22:07 ---- >抽出されたのは5行だけで、値がすべて=#REF!という表示になりました コメントしましたように、想像で書いているところがありますから、要件を誤解している公算は低くないですが ・実際には対象のブックが、もっとたくさんあるということですか? ・なによりも =#REF 。抽出元ブックの Summaryシートの A17:L17 ですけど、ここには数式が入っているのですか? 元々のそちらのコードでコピペをしていたのでアップしたコードでもコピペ方式にしました。 なので、元データが数式ならコピペされたものも数式になります。 具体的には、どんな数式が書かれていたのですか? ・で、数式のまま持ってくるというのは、正しいのですか? それとも、値に変換して持ってくるべきですか? ・転記元ブックのSummaryシートの A17 ですけど、必ず値が入っているのですか? それとも、ブックによっては、A17が空白というものもありますか? アップしたコードは、A17に必ず何かしらの値があるということを前提にしています。 もし、A17 が空白ありうるということなら、転記済みの行の次の行ではなく、取り込み済みの行に上書きされる可能性もありますので 本来 10行なのに 見た目、5行しか取り込めていないという状況はありえます。 これを回避する手立てはありますので、A17 がどうなっているかを教えてください。 （ β） 2017/02/23(木) 22:25 ---- 対象ブックは現在23あるので、23行抽出されるべきなのですが。 ご推測の通り、A17が空白になっているブックがありました。 元データのA17:L17は合計値なので数式が入っていました、SUMです。値に変換したいです。 大変ご迷惑おかけしていますが、引き続きよろしくお願いいたします。 （のんさびぃ） 2017/02/23(木) 23:26 ---- それでは、RecurseX のみ 以下でリバイスして試してください。 Sample はアップ済みのままでOKです。 Private Sub RecurseX(sht As Worksheet, fd As Folder) Dim ff As File Dim sd As Folder Dim erow As Long Dim wbk As Workbook Dim shf As Worksheet Dim tmp As Variant For Each ff In fd.Files If ff.Name <> "MasterTracker Projections.xlsm" Then tmp = Split(ff.Name, ".") If LCase(tmp(UBound(tmp))) = "xlsm" Then If Not ff.Name Like "*" & ThisWorkbook.Name Then Set wbk = Workbooks.Open(ff.path) On Error Resume Next Set shf = wbk.Worksheets("Summary") On Error GoTo 0 If shf Is Nothing Then MsgBox wbk.Name & "には、Summaryシートがないので抽出をスキップします" Else erow = sht.Range("A1").CurrentRegion.Rows.Count + 1 With shf.Range("A17:L17") sht.Range("A" & erow).Resize(, .Columns.Count).Value = .Value End With End If wbk.Close False End If End If End If Next For Each sd In fd.SubFolders Call RecurseX(sht, sd) Next End Sub （ β） 2017/02/24(金) 09:07 ---- もし、上記でOKなら、あくまで参考コードとして。 RecurseX を以下にすると、参照元ブックを開かず、外部参照式での抽出で処理が可能です。 ただし、対象分のすべてに Summary というシートがないと不具合が発生しますから 不安は不安ですが、処理効率は圧倒的にこちらが優れています。。 Private Sub RecurseX(sht As Worksheet, fd As Folder) Dim ff As File Dim sd As Folder Dim erow As Long Dim tmp As Variant Dim frm As String For Each ff In fd.Files If ff.Name <> "MasterTracker Projections.xlsm" Then tmp = Split(ff.Name, ".") If LCase(tmp(UBound(tmp))) = "xlsm" Then If Not ff.Name Like "*" & ThisWorkbook.Name Then frm = "'" & fd.path & "¥[" & ff.Name & "]Summary'!A17" erow = sht.Range("A1").CurrentRegion.Rows.Count + 1 With sht.Range("A" & erow).Resize(, 12) .Formula = "=IF(" & frm & "="""",""""," & frm & ")" .Value = .Value End With End If End If End If Next For Each sd In fd.SubFolders Call RecurseX(sht, sd) Next End Sub （ β） 2017/02/24(金) 09:41 ---- βさん、大変お世話になっております。 別のコードまでご用意いただき、感謝の気持ちでいっぱいです。 こちら時差があって現在夜なのですが、明朝出社次第試して結果をご報告させていただきます。 まずはお礼まで。 （のんさびぃ） 2017/02/24(金) 11:05 ---- βさん、今試してみましたが、どちらも完璧にデータが抽出されました。 元ブックを開かないほうのコードは、おっしゃる通り一瞬で処理されました。 ぜひこちらを使わせていただきます。 親身になって対応していただき、βさんには心より感謝申し上げます。 本当に本当にありがとうございました。 （のんさびぃ） 2017/02/24(金) 21:49... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201702/20170223003629.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97054 documents and 608269 words.
訪問者：