[[20150326162600]] 『マクロボタンを押したら、コピーしたデータを、数』(ALO) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『マクロボタンを押したら、コピーしたデータを、数種類のファイルに自動貼り付け』(ALO)

記帳日  発注先名  店名  現場名  注番  商品名 数量  金額
12/2    山善      A   池永邸    23-744 断熱材 1   296,100
12/6    山善      B   松村邸    6-396 給湯器 1   71,004
12/25    紅中      C   山本邸  26-907 カート 1   18,000
12/26    紅中      D   北川邸  23-920 カウンタ 2   8600
1/5     南商店    E    田中邸  32-1   太陽光 1   1000000

発注先名とは一致しないファイルがいくつか存在します。
たとえば、「1.山善」「2.紅中」「その他」などです。
上記データをコピーして、マクロボタンを押すと、それぞれ入力したい発注ファイルの
一番最後の行に自動的に値のみ貼り付けして、貼り付けたファイルはそのまま閉じるようなマクロはありますでしょうか?

マクロ初心者のため、どなたかご教示いただけますと助かります。

< 使用 Excel:Excel2013、使用 OS:Windows7 >


 ファイル とは ブックですか? マクロブック内のシートですか?

 ブックの場合は、ブック名のことですか? そのブックの、なんというシートに貼り付けるのですか?
 また、こおのブックはどこに保存されているのですか?

 シートの場合、シート名のことですか?

 「上記データをコピーして」どこにコピーするのですか?

 「その他」には何をコピーするのですか?

(β) 2015/03/26(木) 17:07


早速の返信ありがとうございます。
マクロブック内のシートではなく、別のブックとなります。
シート名は、sheet1でお願いします。そのブックは、cドライブ直下に保存されてます。
その他は、他にも発注先名が150件以上あり、それに対して五個のエクセルファイル(ブック)
があり、その四つのどこにも所属しない発注先をその他という名称ファイルにしてます。
150件の発注先に対して、それぞれ保存したいファイル名(五個)の一覧を
作成しおけば、マクロを組んで一気に貼り付けたいファイルの最終行に
保存する事は可能でしょうか?
できれば、マクロ式を教えてほしいです。
(ALO) 2015/03/27(金) 01:02

 横からすみません
 運用方法が尋常じゃないと思います
 ブック毎に分けたデータをどの様に活用するのですか?
 集計にしろ、閲覧にしろ、全てはいったデータベース
 からフィルタなりピボットなりマクロなりで
 都度出力すればいい話ではないですか?

 あげてもらった例で、その他と山善を集計したくなったとき
 別のブックでは不便ですよね?
(稲葉) 2015/03/27(金) 05:19

 稲葉さんのコメントに100票! ですね。

 話はそれますが、よく、「最終報告書スタイル」のシートレイアウト(罫線があったり結合セルがあったり、行がとびとびで配置されていたり)
 に対するデータ処理(蓄積や加工)の質問がよくアップされます。

 で、レイアウトが扱いにくいので、コードもやっかいなものになることが間々あります。

 データはデータとしてシンプルなテーブル形式で、必ず1行目にタイトルがあって、列はA列から連続して配置。
 こんなものにしておいて、必要なものを、その条件で抜出し、必要があれば、見栄えの良い報告書に加工編集する。

 こういう構成がいいと思いますよ。

 で、このデータは、最初は、エクセルシートでもいいでしょうし、量が膨大になれば、そこだけを専門のDBに移す。
 そうすると、DBアクセスの部分だけをかえれば、編集処理プログラムは、ほとんどのロジックを継承できる。
 いいことずくめだと思いますね。

(β) 2015/03/27(金) 07:20


みなさん、回答ありがとうございます。
私も一つのファイルで、ピボットなどを使用して、そのように運用したいのですが、
入った会社がその運用を全支店とも採用してるための苦肉の策です。

毎回どこかに貼り付けたデータの書式を変え、該当のファイルを開き、
そこに入力しないといけないようです。
今は、全て手入力してるようです。

なので、せめてその部分をマクロ化できないかなと思った次第です。
無理なようなら、あきらめます。

(ALO) 2015/03/27(金) 10:29


 できるけど、
 >150件の発注先に対して、それぞれ保存したいファイル名(五個)の一覧を 
 >作成しおけば、マクロを組んで一気に貼り付けたいファイルの最終行に 
 >保存する事は可能でしょうか? 
 一覧にない発注先はどう判別するとか、
 既にコピーが済んでいるデータはどこを見ればわかるのか
 元のデータは残すのか、消すのか
 誤って入力したときに後追いができるのかとか

 色々仕様考えないとだめでしょうね。

 一度直談判してみたらどうでしょう?
 それか支店がたくさんあるなら、簡素化されてるところもあるでしょうし。
(稲葉) 2015/03/27(金) 10:59

 とりあえず、そちらの要望の(と思われる)コードをアップしておきます。
 ★のところは適宜、実際のものに。
 Dドライブ直下のエクセルブック(いくつあってもOK)名とマクロブックの発注先名をLike 比較して当該のブックに追加。
 マッチしないものは、その他.xlsx に追加します。

 要件誤解しているところがあれば指摘してください。
 今から外出するので、何かあれば、コメントアップしておいてください。

 Sub Test()
    Dim fName As String
    Dim fPath As String
    Dim dic As Object
    Dim d As Variant
    Dim otName As String
    Dim cR As Range
    Dim fR As Range
    Dim bR As Range
    Dim c As Range
    Dim w As Variant
    Dim Target As String
    Dim sh As Worksheet

    Application.ScreenUpdating = False

    fPath = "D:\"
    otName = "その他.xlsx"                          '★その他を格納するブック名
    Set dic = CreateObject("Scripting.Dictionary")

    fName = Dir(fPath & "*.xls*")

    Do While fName <> ""
        If fName <> otName Then
            w = Split(fName, ".")
            dic(fName) = w(UBound(w) - 1)   'キー:ブック名、アイテム:拡張子を除いたもの
        End If
        fName = Dir()
    Loop

    With ThisWorkbook.Sheets("Sheet1")              '★マクロブックのリストがあるシート。シート名は実際のものに。
        .AutoFilterMode = False                     '念のためオートフィルター解除
        Set fR = .Range("A1").CurrentRegion         'リスト領域
        Set bR = Intersect(fR, fR.Offset(1))        'リストのデータ領域
        Set cR = .Cells(1, fR.Columns.Count + 2)    'リスト領域から1列あけて作業列を設ける
        fR.Columns(2).Offset(1).Resize(fR.Rows.Count - 1).Copy cR       '発注先をタイトル行を除いてコピー
        cR.CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo      '重複の削除で一意の発注先リストに
    End With

    For Each c In cR.CurrentRegion    '発注先の取り出し

        fR.AutoFilter Field:=2, Criteria1:=c.Value

        '発注名に紐付くブックの判定
        Target = otName
        For Each d In dic
            If dic(d) Like "*" & c.Value & "*" Then
                Target = d
                Exit For
            End If
        Next

        Set sh = Workbooks.Open(fPath & Target).Sheets(1)           '紐付いたブックを開き、最初のシートを取得

        bR.Copy sh.Range("A" & sh.Rows.Count).End(xlUp).Offset(1)   '末尾に追加(コピペ)

        sh.Parent.Close True                                       '開いたブックを保存して閉じる

    Next

    'オートフィルターの解除と作業域のクリア
    fR.AutoFilter
    cR.CurrentRegion.Clear

    MsgBox "処理が完了しました。"

 End Sub

(β) 2015/03/27(金) 12:13


 紐付くブックの判定をループなしにしたものも。

 Sub Test2()
    Dim fName As String
    Dim fPath As String
    Dim dic As Object
    Dim d As Variant
    Dim otName As String
    Dim cR As Range
    Dim fR As Range
    Dim bR As Range
    Dim c As Range
    Dim Target As String
    Dim sh As Worksheet
    Dim reg As Object
    Dim mt As Object
    Dim checkStr As String

    Application.ScreenUpdating = False

    fPath = "D:\"
    otName = "その他.xlsx"                          '★その他を格納するブック名
    Set dic = CreateObject("Scripting.Dictionary")
    Set reg = CreateObject("VBScript.RegExp")

    fName = Dir(fPath & "*.xls*")

    Do While fName <> ""
        If fName <> otName Then
            dic(fName) = True
        End If
        fName = Dir()
    Loop

    If dic.Count > 0 Then
        checkStr = vbTab & Join(dic.keys, vbTab) & vbTab    'ブック名を連結した検索用文字列
    End If

    With ThisWorkbook.Sheets("Sheet1")              '★マクロブックのリストがあるシート。シート名は実際のものに。
        .AutoFilterMode = False                     '念のためオートフィルター解除
        Set fR = .Range("A1").CurrentRegion         'リスト領域
        Set bR = Intersect(fR, fR.Offset(1))        'リストのデータ領域
        Set cR = .Cells(1, fR.Columns.Count + 2)    'リスト領域から1列あけて作業列を設ける
        fR.Columns(2).Offset(1).Resize(fR.Rows.Count - 1).Copy cR       '発注先をタイトル行を除いてコピー
        cR.CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo      '重複の削除で一意の発注先リストに
    End With

    For Each c In cR.CurrentRegion    '発注先の取り出し

        fR.AutoFilter Field:=2, Criteria1:=c.Value

        '発注名に紐付くブックの判定
        Target = otName
        reg.Pattern = vbTab & "[^" & vbTab & "]*" & c.Value & "[^" & vbTab & "]*?" & vbTab    '発注先ワイルドカード
        Set mt = reg.Execute(checkStr)
        If mt.Count > 0 Then        'マッチ
            Target = Mid(mt(0).Value, 2, mt(0).Length - 2)
        End If

        Set sh = Workbooks.Open(fPath & Target).Sheets(1)           '紐付いたブックを開き、最初のシートを取得

        bR.Copy sh.Range("A" & sh.Rows.Count).End(xlUp).Offset(1)   '末尾に追加(コピペ)

        sh.Parent.Close True                                       '開いたブックを保存して閉じる

    Next

    'オートフィルターの解除と作業域のクリア
    fR.AutoFilter
    cR.CurrentRegion.Clear

    MsgBox "処理が完了しました。"

 End Sub

(β) 2015/03/27(金) 13:47


みなさん、ご丁寧にありがとうございます!!助かります。
一度やってみて、不明点あればまたご連絡させてただきます。

私もマクロの神の領域になるよう勉強をつんでいきたいと思います。
(ALO) 2015/03/27(金) 15:44


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.