質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.06%

共有サーバー内にある一覧表へ複数のファイルから転記する

解決済

回答 2

投稿

  • 評価
  • クリップ 1
  • VIEW 3,958

mikiki

score 13

Excel VBA 初心者であまり基礎も理解しておらず申し訳ありませんが、
仕事で急ぎ管理表を作成しなければならなくなりました。
わからないなりにネットで検索しながら作成したのですがつまずきまくっております。
どうぞご教示ください。(>人<;)

 前提・実現したいこと

まず、実現したいことは、
複数の人がそれぞれのファイルに情報を入力します。
その情報を共有サーバー内にある集約用の管理表にそれぞれのタイミングで転記(追記)し、
最新の情報を共有したいと思っております。

これまでは集約管理表に都度ハンドで転記していたのですが、人数が大幅に増え、ファイルを開いた状態で
離席されたりと問題が出てきたのでマクロで集約できないかと下記の通り考えてみました。

<A:入力用(転記元)>
イメージ説明

↓ ↓ ↓ 転記する
<B:【共有】集約管理(転記先)>
イメージ説明

■マクロの手順

  1. 入力用Aからの転記実行
  2. 管理表Bを開いていなければ開き、読み取りで開いていたら元ファイルを開く。(基本、読み取りで開いている)
    ※ここで他の人が元ファイルを開いていたら「他の人が作業中です。しばらく経ってから転記し直してください。」と
    メッセージを出したい。
  3. 入力用AのB列「*」の一つ下の行、C列からM列までをコピーし、管理表BのB列最終行の一つ下の行へ転記する。
  4. 入力用Aの転記した行のB列のセルに「*」を表記させる。
  5. 転記後管理表Bを上書き保存し、閉じて読み取り専用で開く。

 発生している問題・エラーメッセージ

①Bの集約管理ファイルを閉じていると開くのですが、開いていたらメッセージボックスは表示されず
「ファイルが見つかりません。ファイル名保存場所が正しいか・・」と出ます。
②Bの集約管理ファイルを閉じた状態にしてマクロを動かすとAの入力用をコピーせず、Bのファイルのセルを
コピーしにいきます。。
下図参照
イメージ説明
イメージ説明
この先から進めなくなりました。
①および②が解消できればまた進めることができると思うのですが・・
基礎を理解できていないがゆえだと思いますが、助けていただきたいです。。><
よろしくお願いします。

 該当のソースコード

※上記の画像と同じです

Sub 転記()
Dim wB As Workbook, wS As Worksheet
Dim myPath As String, fN As String
Dim LastRow As Long

'①A入力用(転記元)の"D1"を参照し、B共有フォルダの「管理状況」にある
'集約管理(転記先)のブックを開く
Application.DisplayAlerts = False

myPath = "共有サーバー\管理状況\"
fN = "【共有】集約管理" & Range("D1").Value & "月" & ".xlsx"

Workbooks.Open Filename:=myPath & fN, Notify:=False
If ActiveWorkbook.ReadOnly Then
MsgBox "他の人が作業中です。しばらく経ってから転記し直してください。"
ActiveWorkbook.Close
Else
Sheets("list").Activate
Range("A1") = Now
End If
Application.DisplayAlerts = True

'②A入力用(転記元)のB列「*」の一つ下のC列からM列までをコピー
With ThisWorkbook.Worksheets("入力フォーム")
x = 4
Do While Cells(x, 3).Value <> ""
If Cells(x, 2).Value <> "*" Then
Cells(x, 2).Value = "*" '----コピーと同時にB列へ転記すみ「*」を追記
Range(Cells(x, 3), Cells(x, 13)).Copy

'③共有フォルダの「管理状況」にある集約管理へ転記
Set wB = Workbooks(fN)
Set wS = wB.Worksheets("list")

LastRow = wS.Cells(Rows.Count, 2).End(xlUp).Row  '----B列の最終ひとつ下へ値貼り付け
wS.Range("B" & LastRow).Offset(1, 0).Select
ActiveSheet.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End If
x = x + 1
Loop
End With

Application.CutCopyMode = False

wB.Save
wB.Close '----元のファイルを保存し閉じる

MsgBox "転記しました。"

Workbooks.Open Filename:=myPath & fN, ReadOnly:=True  '----読み取り専用で開く

End Sub

 試したこと

 補足情報

使用バージョン:Excel2010

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

+4

①Bの集約管理ファイルを閉じていると開くのですが、開いていたらメッセージボックスは表示されず「ファイルが見つかりません。ファイル名保存場所が正しいか・・」と出ます。

とりあえず既に開いている場合に閉じる処理が無いのが問題ですね。

②ActiveSheet.PasteSpecialから進めなくなりました。

このエラーの原因は本来Range.PasteSpecialにしか存在しないパラメータ「Paste:=」をWorksheet.PasteSpecialに対して使用しているためですね。
どちらも同じ名称のメソッドですから、編集の過程で変えてしまったのでしょう。
本件はコピー&ペーストが必要ない事例ですが、そこが質問のキモなのでそのまま残しています。

しかし、色々とバグの原因が混ざっているので順番に指摘していきます。

1.DisplayAlertsの位置が良くない。
この手のスイッチは必要最小限な範囲に使うように心がけたほうが良いです。
例えば今回の場合はOpen時の様々な警告を無視するためだと思いますのでOpenだけに適用しています。

2.Withの使い方がおかしい。
WithステートメントはWorkbook、Worksheet、Rangeなどの変数の代替するためのものです。
利用するにはドットから初めなければなりませんが、提示されたコードではドットが付いていません。

3.極力ActiveSheetや省略Cellsは使わないように。
Withが上手く使えていないのが原因で、「Cells(x, 2).Value = "*"」などはActiveSheetが省略されたものとして動作します。
※プログラムを標準モジュールに書いた場合
従って、前に記載されている「Sheets("list").Activate」の影響でlistに対して処理することになり、意図したように動作しないはずです。
基本的にシートオブジェクトは指定するようにしてください。

たとえば、せっかく「Set wS = wB.Worksheets("list")」としているのに、すぐ下でActiveSheet.PasteSpecialとしていますよね。
同じオブジェクトを指すのですからwSを使いましょう。
今回の場合、Open直後に「Sheets("list").Activate」を実行しているので、この時点で変数に代入しておけばOKです。

4.インデントに手を抜かないこと。
コードが読みづらくなるということは、ミスを発見しずらくなります。
面倒でもインデント(TAB)はきれいに整えましょう。

5.処理中にRange.Selectは使わないこと。
下記のコードを見て分かるように、正しく書けばSelectは必要ありません。
もしアクティブブック・シートが切り替わった状態でSelectするとエラーの原因となりますので、どうしても使うときはブックやシートもActiveにしましょう。
マクロの最後に、マクロ実行後に選択していてほしい箇所をSelectするような目的で使うのが正しい使い方です。
とはいえ、デバッグのときは処理工程でSelectしてくれたほうが、わかりやすくて便利なので一応コメントで残しています。

できるだけ構造を変えないように修正したものがこちらです。
一応ローカル環境でデバッグしたので動くと思いますが、ご自分でも良くデバッグしてください。

Sub 転記()
    Dim wB As Workbook, wS As Worksheet
    Dim myPath As String, fN As String
    Dim x As Long

    '①A入力用(転記元)の"D1"を参照し、B共有フォルダの「管理状況」にある
    '集約管理(転記先)のブックを開く
    myPath = "共有サーバー\管理状況\"
    fN = "【共有】集約管理" & Range("D1").Value & "月" & ".xlsx"
    'ローカルテスト用
    'myPath = "C:\tmp\"
    'fN = "管理用B.xlsx"

    '既にfNを開いていたら閉じる
    On Error Resume Next
    Set wB = Workbooks(fN)
    On Error GoTo 0
    If Not wB Is Nothing Then
        wB.Close False
    End If

    Application.DisplayAlerts = False
    Set wB = Workbooks.Open(Filename:=myPath & fN, Notify:=False)
    Application.DisplayAlerts = True

    If wB.ReadOnly Then
        MsgBox "他の人が作業中です。しばらく経ってから転記し直してください。"
        wB.Close False
        Exit Sub
    Else
        Set wS = wB.Sheets("list")
        wB.Activate    '←普通は必要ないが、一応。
        wS.Activate
        wS.Range("A1") = Now
    End If

    '②A入力用(転記元)のB列「*」の一つ下のC列からM列までをコピー
    With ThisWorkbook.Worksheets("入力フォーム")
        x = 4
        Do While .Cells(x, 3).Value <> ""
            If .Cells(x, 2).Value <> "*" Then
                .Cells(x, 2).Value = "*" '----コピーと同時にB列へ転記すみ「*」を追記
                .Range(.Cells(x, 3), .Cells(x, 13)).Copy

                '③共有フォルダの「管理状況」にある集約管理へ転記
                 '----B列の最終ひとつ下を選択してから値として貼り付け
                With wS.Cells(wS.Rows.Count, 2).End(xlUp).Offset(1, 0)
                    'wB.Activate    '←Selectを使いたいときはコレも書いたほうが安全
                    'wS.Select     '←Selectをry
                    '.Select         '←省略可
                    .PasteSpecial Paste:=xlPasteValues, _
                        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End With
            End If
            x = x + 1
        Loop
    End With
    Application.CutCopyMode = False

    'データの末尾の次の行を選択
    wB.Activate
    wS.Select
    wS.Cells(wS.Rows.Count, 2).End(xlUp).Offset(1, 0).Select

    Application.DisplayAlerts = False
    wB.Save
    Application.DisplayAlerts = True
    wB.Close False '----元のファイルを保存し閉じる

    MsgBox "転記しました。"

    Workbooks.Open Filename:=myPath & fN, ReadOnly:=True  '----読み取り専用で開く

End Sub

尚、本件はこのように1行づつコピー&貼り付けでも問題ないと思いますが、大量のデータを処理する場合は以下のような修正が必要です。
1.先に更新する行数を求めてから複数行をまとめて処理する。
2.コピー&ペーストではなく値の直接転写を行う。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/09/30 11:18

    早速のご回答ありがとうございます!!本日は台風の影響で出社ができず共有サーバー上では試せていないのですが、ローカルで動かすことができました。
    また、natoさんの構文と説明を拝見し、全体的にルール(基礎)を理解していない私でもすーっごいわかりやすくてスッと入ってきました!

    1.DisplayAlertsはOPENのみに対して記述しないといけなかったんですね。
    2.Withの使い方、理解してませんでした。。
    3.ActiveSheet わからなくてマクロの記憶でコピペしたりしたのでこのような変な記述になりました。。
    4.インデントを揃えておくことの重要さがよくわかりました。要学習です。
    5.3.と同じように記述してました。でもSelectの正しい使い方がわかりました!

    2日間悩みに悩んで思い切って投稿させてもらいましたが、予想以上にご丁寧にひとつひとつ説明してくださり、本当に感謝の言葉もございません。これぞ神対応!!(_ 人_) 
    それから、VBAおもしろいです。これをきっかけに会社にVBAセミナーへの受講を上申し、学習したいと思います。

    キャンセル

  • 2018/09/30 12:41

    質問が丁寧だったので、私もちゃんと回答したまでです。コピペの継ぎ接ぎでも自力でこれだけの質問ができるなら、あとはデバッグのコツや調べ方を身につければどんどん上達していくと思いますよ。私もそうでした。VBEの操作(ブレークポイント、F8ステップ、ウォッチ、イミディエイトウィンドウ、F2オブジェクトブラウザの使い方を覚えると、大抵は自力で解決出来るようになると思います。
    それと次回投稿するときは、コード部分はTeraTailのMarkdown記法に沿って記載してくださいね。そうするとインデントも消えずに貼り付けられます。

    キャンセル

+1

②についてコメントしてます。

ActiveSheet.PasteSpecial Paste:=xlPasteValues, _
 Operation:=xlNone, SkipBlanks:=False, Transpose:=False 


ActiveSheetが何を指しているのかイミディエイトウィンドウで確認し、
正しいSheetを指定するためのコード修正で解決すると思います。

<イミディエイトウィンドウでの確認方法>
Debug.Print ActiveSheet.name

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/09/30 11:33

    早速の回答ありがとうございます。
    「イミディエイトウィンドウ」の存在および確認方法初めて知りました。
    自分の記述を改めて確認したいと思います。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.06%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る