[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『CSVデータをエクセルのブックに添付するマクロ』(ゆり)
ご覧いただきありがとうございます。
最近必要にかられマクロを勉強し始めましたが、複雑なものがまだ組めないので助力いただきたく思います。
○○フォルダの大本のフォルダがあります。
『CSV』というフォルダに『報告A』『報告B』というフォルダがありCSVが複数(月によって変動)入っております。
それをメインの関数を組んであるエクセルbookの対応したページ(タブがCSV名)に内容がコピーされるマクロを組みたいのですがどのように組めばよろしいでしょうか?
※エクセルbookの1シート目に、『報告A』『報告B』『両方』のボタンを準備しボタンを押すと実行
エクセルブックのタブは原本を作り先に入力しておくことは可能です。
また、普段こちらのフォルダは下記の状態で、サーバー等に保管され、各自がディスクトップ上で作業を行います。
○○フォルダ
→エクセルbook
CSVフォルダ
→報告書A
報告書B
報告書A
→△△(1).csv〜△△(9).csv
□□(1).csv〜□□(17).csv
報告書B
→△△(1).csv〜△△(7).csv
□□(1).csv〜□□(20).csv
時折、間の数字がない時もあります。
□□(1).csv〜□□(9).csv
□□(15).csv〜□□(17).csv
簡単なリネームやフォルダを開く、ブックを合体させるといった個別のものは作っているのですが、一連の動作を一つのボタンで行いたいと言われて悩んでおります。
お年寄りが多い職場なので、できるだけ簡略化できればと思います。
皆様お忙しいかと思いますが、よろしくお願いします。
< 使用 Excel:Excel2010、使用 OS:Windows7 >
Sub 報告A_Click()
Call 読み込み("報告書A") End Sub Sub 報告B_Click() Call 読み込み("報告書B") End Sub Sub 両方_Click() Call 読み込み("報告書A") Call 読み込み("報告書B") End Sub Sub 読み込み(s As String) Dim m As String Dim p As String Dim f As String Dim c As Workbook Dim t As Worksheet With ThisWorkbook m = .Path & "\" & s & "\" p = m & "*.csv" Application.ScreenUpdating = False f = Dir(p) Do While f <> "" Set c = Workbooks.Open(Filename:=m & f) On Error Resume Next Set t = .Worksheets(Replace(f, ".csv", "")) If Not t Is Nothing Then c.Worksheets(1).Range("A1") _ .CurrentRegion.Copy _ t.Range("A" & Rows.Count).End(xlUp).Offset(1) End If c.Close False f = Dir Loop Application.ScreenUpdating = True End With End Sub
こんな感じでしょうか?
(ウッシ) 2017/02/23(木) 15:40
とりあえずリネームした報告書Aで試してみたのですが、コピーされてきませんでした。。。
(ゆり) 2017/02/23(木) 16:16
CSVフォルダ、忘れてました。
「読み込み」だけ差し替えて下さい。
Sub 読み込み(s As String)
Dim m As String Dim p As String Dim f As String Dim c As Workbook Dim t As Worksheet With ThisWorkbook m = .Path & "\CSV\" & s & "\" p = m & "*.csv" Application.ScreenUpdating = False f = Dir(p) If f = "" Then MsgBox "ファイル見当たりません。 " & p Exit Sub End If Do While f <> "" Set c = Workbooks.Open(Filename:=m & f) On Error Resume Next Set t = .Worksheets(Replace(f, ".csv", "")) If Not t Is Nothing Then c.Worksheets(1).Range("A1") _ .CurrentRegion.Copy _ t.Range("A" & Rows.Count).End(xlUp).Offset(1) Else MsgBox Replace(f, ".csv", "") & " シート見当たりません。 " End If c.Close False f = Dir Loop Application.ScreenUpdating = True End With End Sub
(ウッシ) 2017/02/23(木) 16:25
ありがとうございます!!
データ反映されました!
ただ、1行目が空欄になってしまうのですが
A1から入力されるようにはできるのでしょうか?
(ゆり) 2017/02/23(木) 16:41
『報告A』『報告B』『両方』の時、それぞれ同じシート名の時があるようですけど、
どうするのですか?
『報告A』『報告B』別々に実行なら、1行目から書き換えてもいいのでしょうけど、
『両方』の時は、『報告A』で更新されたシートが、『報告B』で上書き更新されちゃいますよ?
(ウッシ) 2017/02/23(木) 16:49
すみません。
報告書A
→△△(1).csv〜△△(9).csv
□□(1).csv〜□□(17).csv
報告書B
→△△(1).csv〜△△(7).csv
□□(1).csv〜□□(20).csv
報告書A
→報告書A_△△(1).csv〜報告書A_△△(9).csv
報告書A_□□(1).csv〜報告書A_□□(17).csv
報告書B
→報告書B_△△(1).csv〜報告書B_△△(7).csv
報告書B_□□(1).csv〜報告書B_□□(20).csv
この形で報告書のフォルダ名が頭についております。
すみません
(ゆり) 2017/02/23(木) 16:56
それなら、
Sub 読み込み(s As String)
Dim m As String Dim p As String Dim f As String Dim c As Workbook Dim t As Worksheet With ThisWorkbook m = .Path & "\CSV\" & s & "\" p = m & "*.csv" Application.ScreenUpdating = False f = Dir(p) If f = "" Then MsgBox "ファイル見当たりません。 " & p Exit Sub End If Do While f <> "" Set c = Workbooks.Open(Filename:=m & f) On Error Resume Next Set t = .Worksheets(Replace(f, ".csv", "")) If Not t Is Nothing Then t.UsedRange.ClearContents c.Worksheets(1).Range("A1") _ .CurrentRegion.Copy t.Range("A1") Else MsgBox Replace(f, ".csv", "") & " シート見当たりません。 " End If c.Close False f = Dir Loop Application.ScreenUpdating = True End With End Sub
で。
(ウッシ) 2017/02/23(木) 17:04
ありがとうございました!
無事に作成できました!
迅速な対応ありがとうございます!
(ゆり) 2017/02/23(木) 18:16
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.