[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数のCSVデータを、マクロブックの特定のセルにコピー』（minoru）
お世話になります。
This timeフォルダに７０前後のコピー元のCSVファイルがあります。
ファイル名は６ケタの整数です。
各コピー元CSVファイルのE1:E51の数値を、マクロエクセルの「まとめシート」の
特定列にコピーしたい。
条件
まとめシートの１行目（A1からBR1）にコピー元のファイル名と同一の
数値が固定で入力されています。
コピー元のCSVファイル名と、同一の数値が入力されている列の、
５行目から５５行目に、コピー元のE1:E51の値をコピーしたい。
「まとめシート」のA1セルが100001の場合は、コピー元のCSVファイル名100001の"E1:E51"の数値を、「まとめシート」のA5:A55にコピーする。
「まとめシート」B1セルが123456で、This timeフォルダ内に同一のファイル名が無い場合は、「まとめシート」B5:B55はブランクで何もしない。
「まとめシート」A1からBR1に記載された数値以外の、コピー元CSVファイルについても何もしない。
現状は下記のマクロでThis timeフォルダ内のCSVデータの５列目を取込していますが、指定したセルへのコピー記述についてご教示願います。
下記のコードにはこだわりませんので、よろしくお願いします。
Sub 転記()
Const FolderPath As String = "C:\Users\Desktop\This time"
Dim Filename As String
Dim Sh0 As Worksheet, Sh As Worksheet
Dim c As Long
Set Sh0 = ActiveSheet
Filename = Dir(FolderPath & "\*.csv")
Do Until Filename = ""
c = c + 1
Set Sh = Workbooks.Open(FolderPath & "\" & Filename).Sheets(1)
Sh.Columns(5).Copy Sh0.Columns(c)
Application.DisplayAlerts = False
Sh.Parent.Close
Application.DisplayAlerts = True
Filename = Dir()
Loop
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
Sub 転記の整理()
Const FolderPath As String = "C:\Users\Desktop\This time"
Dim Filename As String
Dim dstSH As Worksheet
Dim c As Long
Set dstSH = ActiveSheet
Filename = Dir(FolderPath & "\*.csv")
Do Until Filename = ""
c = c + 1
With Workbooks.Open(FolderPath & "\" & Filename).Sheets(1)
.Columns(5).Copy dstSH.Columns(c)
'Application.DisplayAlerts = False '←いらない
.Parent.Close
'Application.DisplayAlerts = True '←いらない
Filename = Dir()
End With
Loop
End Sub
そして、質問のほうですが、Dir関数でファイルを探す方法がわかっているようなので、1行目のA〜最終列までの値を順番に取得して、ファイルがあるがどうか調べてみればよいでしょう。
そして、ファイルが存在するときだけ
(1)csvファイルをブックとして開き (2)開いたブックの1番目のシートの「E1:E51」をコピーして (3)まとめシートの5行目の該当列に貼付 (4)開いたブックを閉じる
という処理をすればよいと思います。
答えを全部書いてしまうと考える機会をうばってしまいますので、とりあえずヒントコードを提示します。（といいつつ、コンパイルエラーにならないことくらいしかチェックしてないのでミスっていたらごめんなさい）
Sub Sample()
Const FolderPath As String = "C:\Users\Desktop\This time\"
Dim i As Long
With ActiveSheet
For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
If Dir(FolderPath & .Cells(1, i).Value & ".csv") <> "" Then
MsgBox i & "列目の「" & .Cells(1, i).Value & ".csv」は存在します"
End If
Next
End With
End Sub
（もこな２） 2018/11/25(日) 00:30
レスありがとうございます。
今使用しているコードも色々な方の回答の
つぎはぎで使用していますが、
i でファイル名を取得して
Filename に iを代入・・・
で、基のCSVファイルのオープンと
コピーは理解できそうですので、
試行してみます。
転記先のセル範囲の選択（決定）について、
ヒントなりコードを教えていただきたく
よろしくお願いします。
（minoru） 2018/11/25(日) 11:51
元のコードに書いてありますよ
下記の.Copyの後ろに注目してみましょう。
.Columns(5).Copy dstSH.Columns(c)
↑
ココ
【参考】
https://www.moug.net/tech/exvba/0050101.html
（もこな２） 2018/11/25(日) 12:01
こんいちは ＾＾ 回答とは言えないかもしれませんが。（お望みのものではない？） お勉強の何かの足しにでもなれば。。。しあわせです。。。ならないかもですが（自信がない） A＾_＾； パスは環境に合わせ変更してください一番左端のシートが取り纏めシートになります。 お試しの際は、（バックアップは必ずお取りください。）
Sub 転記()
'Const FolderPath As String = "C:\Users\Desktop\This time"
Const FolderPath As String = "D:\excel\This time\"
Dim Filename As String
Dim Sh0 As Worksheet, Sh As Worksheet, wb As Workbook
Dim c As Variant
Dim rr As Range
Set Sh0 = Workbooks(ThisWorkbook.Name).Worksheets(1)
Filename = Dir(FolderPath & "\*.csv")
If Sh0.UsedRange.Rows.Count > 4 Then
Intersect(Sh0.UsedRange, Sh0.Range(Sh0.Rows(5), Sh0.Rows(Sh0.UsedRange.Rows.Count))).Clear
End If
Do Until Filename = ""
'c = c + 1
Set wb = Workbooks.Open(FolderPath & "\" & Filename)
Set Sh = wb.Worksheets(1)
Set rr = Sh.UsedRange
c = WorksheetFunction.Match(CLng(Trim(Left(Filename, 6))), Sh0.Rows(1).SpecialCells(2), 0)
If Not IsError(c) Then
Intersect(rr.Columns(5), Sh.Range(rr.Rows(1), rr.Rows(51))).Copy
Sh0.Cells(5, c).PasteSpecial xlPasteValues
End If
DoEvents
wb.Close False
Filename = Dir()
Loop
End Sub
（隠居じーさん） 2018/11/25(日) 13:27
レス回答ありがとうございます。
おかげさまで、事務作業時間が大幅に短縮できそうです。
もこな２様にご指導いただきました
ファイル名を特定して、該当ファイルを開き、コピーして、該当のセル位置へ転記は、
いまだループしません、デバックしまくりです。
もう少し試行してみます。
隠居じーさん様
レスありがとうございます。
思い通りに動作しました、コード記述を拝見して、アプローチの思考の違いがわかりました。
ニックネームから推察させていただくと、現役引退のようですが、敬服です。
お時間があれば、ご教授願いたく。
MATCH関数で、６桁のファイル名を特定することは試行していたのですが、
Trim関数とClng関数は、思考の範疇外で今まで使用したことがありません。
Trim関数を除外しても動作しましたが、Trim関数を使用する理由はエラー防止でしょうか？
Variant型ですので、Clng関数を除外しても動作すると思いましたが、動作しませんでした
Clng関数についても、説明いただけるとうれしいです。
（minoru） 2018/11/25(日) 21:31
すみません トリム、使うなら c = WorksheetFunction.Match(CLng(Left(Trim(FileName), 6)), Sh0.Rows(1).SpecialCells(2), 0) でなければ、あまり意味はなさそうです ＾＾； 修正お願いいたします。 m(__)m Trim関数 両端の空白を除去する。だったと思います。除去できない迷惑な空白文字列もあるみたいですが とりあえず、入力時、間違って最後に半角スペースなんかが有った場合の誤作動防止対策をとる 私の習性みたいなもので ＾＾；必要なかったかもしれませんね。 仮に " 123456.csv"でも "123456.csv" にしてくれるので 。。。マッチすると思います。
Clng関数 はファイル名について ＞＞数値が固定で入力されています。 とのご説明でしたのでロング型の数値に変換しました。Valだとマイナス表示用になにやら 空文字列が入るような記憶が（間違いかも^^;;; 調べてません） エクセル様が気を利かして【うん?、これは文字列だけど数値みたいだから数値に変換 しておくか。。。】みたいなこともあるみたいですが 今回は許してくれませんでしたね。 詳細につきましては、それぞれ 【ＶＢＡ ？？？】なんかで検索してみてくださいね。 いい加減な説明で済みませんm(_ _)m
他にもいろいろな方法があると思いますが もこな２さん のロジックをおかりする方法だと下記の様な感じでも。 なにかの参考まで。Sheet1 がまとめシートになります。
Option Explicit
Sub main()
Dim i As Long
Dim rr As Range
Dim buf
Dim FileName As String
Dim PathName As String
Dim wb As Workbook
PathName = "D:\excel\This time\"
With Worksheets("Sheet1")
If .UsedRange.Rows.Count > 4 Then
Intersect(.UsedRange, .Range(.Rows(5), .Rows(.UsedRange.Rows.Count))).Clear
End If
buf = .Rows(1).SpecialCells(2)
For i = 1 To UBound(buf, 2)
FileName = buf(1, i)
If Dir(PathName & FileName & ".csv") <> "" Then
Set wb = Workbooks.Open(PathName & FileName & ".csv")
With ActiveSheet
Set rr = .Cells(1).CurrentRegion
Intersect(rr.Columns(5), .Range(rr.Rows(1), rr.Rows(51))).Copy
ThisWorkbook.Worksheets("Sheet1").Cells(5, i).PasteSpecial xlPasteValues
wb.Close
End With
End If
DoEvents
Next
End With
End Sub
（隠居じーさん） 2018/11/26(月) 00:02
＞ファイル名を特定して、該当ファイルを開き、コピーして、該当のセル位置へ転記は、
＞いまだループしません、デバックしまくりです。
どうでもいいことですが、正しくは【実行時エラー】が発生して、そのまま「終了」させるか「デバック（プログラム修正作業）」するのか聞かれている状態でしょうね。たぶん。
（うまくいかなくてプログラム修正を繰り返してるという意味で使ってるならあってるでしょうけど。）
さて、細かいツッコミはさておき、実行時エラーが発生して中断されている状態で「デバッグ」を選択すると、エラーが発生する（発生している）行が黄色くハイライトされて表示されるとおもいますので、全体のコードと、どの行でどのようなエラー（エラーナンバーとメッセージ内容）が出るのかを提示されると、皆さんあっという間に添削してくれるとおもいますので、個人情報につながるような部分は隠すにしても、現状のコード全体を提示することを検討されるとよいとおもいます。
また、上記の通り私が質問を勘違いしているのかもしれませんが、100001、123456、100002・・・というように１行にデータが数字が入力されていて、
A1:100001 →100001.csv というファイルがフォルダに存在する場合→、E1:E51をA5以下に貼付 B1:123456 →123456.csv というファイルがフォルダに存在しない場合 →なにもしない C1:100002 →100002.csv というファイルがフォルダに存在する場合→、E1:E51をC5以下に貼付
みたいな感じだとおもったんですが違いましたかね。
もし想像どおりで、まとめシートが存在するブックの標準モジュールにマクロを記述するなら、こんな感じになるとおもいます。
Sub Sample改()
Const FolderPath As String = "C:\Users\Desktop\This time\"
Dim i As Long, MySTR As String
Dim srcWB As Workbook
Stop '←ブレークポイントの代わり
With ThisWorkbook.Worksheets("まとめ")
For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
MySTR = FolderPath & .Cells(1, i).Value & ".csv"
'ファイルがあるときだけ処理
If Dir(MySTR) <> "" Then
Set srcWB = Workbooks.Open(MySTR)
srcWB.Worksheets(1).Range("E1:E51").Copy .Cells(5, i)
srcWB.Close
End If
Next
End With
End Sub
※実データを用意するのがめんどくさかったのでテストしてないのでミスがあったらごめんなさい。
（コンパイルエラーにならないことはチェック済）
（もこな２） 2018/11/26(月) 22:19
minoruさん、すみません
m(_ _)m
もこな２さん
ありがとうございます
（隠居じーさん） 2018/11/27(火) 00:07
Sub Sample改二()
Stop '←ブレークポイントの代わり
Const FolderPath As String = "C:\Users\Desktop\This time\"
Dim i As Long, MySTR As String
Dim dstSH As Workbook: Set dstSH = ThisWorkbook.Worksheets("まとめ")
For i = 1 To dstSH.Cells(1, dstSH.Columns.Count).End(xlToLeft).Column
MySTR = FolderPath & dstSH.Cells(1, i).Value & ".csv"
'ファイルがあるときだけ処理
If Dir(MySTR) <> "" Then
With Workbooks.Open(MySTR).Worksheets(1)
.Range("E1", .Cells(.Rows.Count, "E").End(xlUp)).Copy dstSH.Cells(5, i)
Parent.Close
End With
End If
Next
End Sub
元データが、CSVファイルとのことですから、ブックとして開くのではなく、外部データ（テキスト）として取り込むという方法も使えますので、興味があれば「マクロの記録」機能を使ってどのような命令を使えば良いのかしらべてみるとBetterかなと思います。
（もこな２） 2018/11/28(水) 13:09
お世話になります。
連休後は妙な顧客対応で多忙となり、レス確認できませんでした。
追加のコードまでご教示いただきありがとうございます。
月末から月初までは、業績数値の作成、確認、検証等で
毎日１３時間エクセルと向き合いますが、お二人様から
ご教授頂きましたコードで、１２時間ぐらいに短縮できそうです。
大いに感謝しており、誠にありがとうございます。
もこな２様に指導いただきましたコードで
開くファイル名を特定してから、
開く⇒コピー⇒コピー先特定⇒貼付⇒ 繰り返すのコードを
試行しておりましたが、最初のファイル名特定からエラーで
困っておりました。
ギブアップのレスをアップしようとWEBを開いたところ、
隠居じーさん様のコードを確認した次第です。
追加のコードはしっかり読み込んで理解しておりませんが
早速、明日にでも会社で試してみます。
本当にありがとうございます。
（minoru） 2018/11/28(水) 21:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.