[[20170223145330]]　『CSVデータをエクセルのブックに添付するマクロ』（ゆり）　ページの最後に飛ぶ

『CSVデータをエクセルのブックに添付するマクロ』（ゆり）

ご覧いただきありがとうございます。
最近必要にかられマクロを勉強し始めましたが、複雑なものがまだ組めないので助力いただきたく思います。

○○フォルダの大本のフォルダがあります。

『CSV』というフォルダに『報告A』『報告B』というフォルダがありCSVが複数（月によって変動）入っております。

それをメインの関数を組んであるエクセルbookの対応したページ（タブがCSV名）に内容がコピーされるマクロを組みたいのですがどのように組めばよろしいでしょうか？

※エクセルbookの1シート目に、『報告A』『報告B』『両方』のボタンを準備しボタンを押すと実行

エクセルブックのタブは原本を作り先に入力しておくことは可能です。

また、普段こちらのフォルダは下記の状態で、サーバー等に保管され、各自がディスクトップ上で作業を行います。

○○フォルダ
→エクセルbook
　CSVフォルダ
　→報告書A
　報告書B

報告書A
　→△△（１）.csv～△△（９）.csv
　　□□（１）.csv～□□(１７）.csv
報告書B
　→△△（１）.csv～△△（７）.csv
　　□□（１）.csv～□□(２０）.csv

時折、間の数字がない時もあります。
□□（１）.csv～□□(９）.csv
□□（１５）.csv～□□(１７）.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
　→△△（１）.csv～△△（９）.csv
　　□□（１）.csv～□□(１７）.csv
報告書B
　→△△（１）.csv～△△（７）.csv
　　□□（１）.csv～□□(２０）.csv

報告書A
　→報告書A_△△（１）.csv～報告書A_△△（９）.csv
　　報告書A_□□（１）.csv～報告書A_□□(１７）.csv
報告書B
　→報告書B_△△（１）.csv～報告書B_△△（７）.csv
　　報告書B_□□（１）.csv～報告書B_□□(２０）.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

コメント返信：

[ 一覧(最新更新順) ]

[[20170223145330]] 『CSVデータをエクセルのブックに添付するマクロ』（ゆり） ページの最後に飛ぶ

[[20170223145330]]　『CSVデータをエクセルのブックに添付するマクロ』（ゆり）　ページの最後に飛ぶ