[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フラグのついたデータを別シートに転記したい』（苦戦４日目）
タイトルのようなことを行いたく参考書とネットを見ながら試行錯誤しております。 自分のやりたいことに近いVBAのコードを探しては実行してみているのですが、 うまくいかずこちらに参りました。 ご教示の程、よろしくお願いいたします。
行いたい事とシートの構成は以下の通りです。
sheet1のA列のフラグ（〇があるかないか）を見る
フラグがあった場合→sheet1のP列のシート名を見る
該当の転記先シートにそのデータが転記されているか否かを判断
転記済なら上書きをするか否か？ (出来ればここで、sheet1のD列、I列、K列の値を表示し、 このデータを転記しますか？とメッセージを出したいです）
未転記なら新規で転記するか？
新規に転記ならsheet2の指定のセル番地に転記
次のフラグを見る→繰り返し
sheet1 受注データ
A列からQ列まで使用（1行目は項目名）
A列…フラグ（〇をつける）
B列〜P列まで…日付等のデータが入っています。
P列…転記先のシート名（3種類）が入っています。
sheet2 sheet1のA列に〇がついたデータを転記させたいシート（3種類あります）
1つのデータを転記させるのに構成上7行目から開始で5行使用しています。
A2に○が付いていてQ列のシート名がsheet2だった場合。
sheet1 → sheet2
P列の値 → A7へ
C列の値 → A8へ
H列の値 → A9へ
I列の値 → A10へ
F列の値 → E5へ
L列の値 → D6へ
M列の値 → D7へ
K列の値 → F9へ
J列の値 → D8へ
続けてA4に○が付いていてQ列のシート名がsheet2だった場合。
sheet1 sheet2
P列の値 → A12へ
C列の値 → A13へ
H列の値 → A14へ
I列の値 → A15へ
F列の値 → E10へ
L列の値 → D11へ
M列の値 → D12へ
K列の値 → F14へ
J列の値 → D13へ
Excel2007です。 ご教示よろしくお願いいたします。
ちょっと不明点がいくつかあるのですが、
＞該当の転記先シートにそのデータが転記されているか否かを判断 ってのは、どの項目をみて判断できるのですか？ まさか、転記前のsheet1のB:Pに該当するセルすべての値を確認するのでしょうか？
でも、全部一致なら 上書きも何もないですよね。。。
それから、 ＞A2に○が付いていてQ列のシート名がsheet2だった場合。 最初の転記先（7:10行）に転記する様ですが すると コード実行前にはデータは入ってないってことですよね？
すると、転記済みかどうかはsheet1の内容だけで判断できるってことですか？
(HANA)
HANAさま レスいただきありがとうございます。 ご指摘いただき、自分の考えの浅さにがっくりしました…。 申し訳ありませんでした。 どのような仕様にするか考えてみました。
＞該当の転記先シートにそのデータが転記されているか否かを判断
これについてですが、 sheet1に受注データを毎日csvデータで落として、 それを加工→sheet2のスケジュール表に転記という流れなのですが、 このデータを動かす初日は〇のついたデータ全て転記。 翌日のことを想定して質問に書かせていただいたのですが、 B:Pの全ての値ではなく、 sheet1のD列にある値で判断したいと思います。 D列の値がsheet2のA7、A12、A17と+5ずつ足されたセルに入っているか否か、 入っていれば、転記済み（上書きではなく「転記済みです」としたいです） 入っていなければ、新規転記
＞A2に○が付いていてQ列のシート名がsheet2だった場合。
こちらに関しても同じで、 このデータを動かす初日にはsheet2にはなにも転記されていない状態になりますので、 A列についた〇の行のデータはすべて転記することになります。
翌日からはsheet2にsheet1のD列の値があるか否かで判断していきたいです。
sheet1の内容で転記済みか否かの判断なんて出来ないですよね…。 考慮不足で申し訳ありません。
VBA初心者でユーザーフォームから転記したり、 今回のようにCSVデータを開いてコピーして加工したり といった事しか経験がありません。 何とかこのデータを仕上げたく頑張ってはいるのですが…
申し訳ありませんが、お力を貸していただきたくお願い申し上げます。 （苦戦４日目）
エクセルで取り扱いが簡単なのは 毎日.CSVの様な 一つの情報が一行で書かれているデータです。 一方、人が見やすいのは、（おそらく）Sheet2〜Sheet4の様なデータだと思います。
その兼ね合いが難しいのですが、提案としてはもう一枚シートを用意して A列に「○」が付いていて Sheet2〜Sheet4に転記すべき値が有るデータが一覧に成っている表 を作り、その表から Sheet2〜Sheet4にデータを参照させる方法です。
すると、 ＞sheet2のA7、A12、A17と+5ずつ足されたセルに入っているか否か なんて難しく考えず Sheet5のD列に入っているか だけを確認すれば良いですよね。 ・・・ここは、D列&P列 で確認が必要でしょうか？
Sheet2〜Sheet4にデータを参照させる方法として それぞれのシートの その他の所がどの様に成っているか、教えてもらえませんか？
転記先として、指定されているセル以外は 何も入力は無いのでしょうか？ また、何も入力しなくて良いのでしょうか？
それから、何か通し番号の様なものは無いのでしょうか？
また、Sheet1のデータは ＞B列〜P列まで…日付等のデータが入っています。 と言う事ですが、データが入っていない可能性もありますか？ それとも、すべての列にデータが入っているのでしょうか？
とりあえず、サンプルコードです。 ご説明によっては、変更するかもしれませんが。。。
Sheet1・・・毎日.CSVが加工されたデータ Sheet2〜Sheet4・・・各スケジュール表 Sheet5・・・累積データ
Sheet5の1行目には、Sheet1の1行目と同じ見出しを入れておいて下さい。
コード作成にあたり、当初のご説明のセル番地が
＞7行目から開始で5行使用
とずれている様に思いますので、こちらで勝手に変更しました。
最初の方に有る
MyCA = Array("", "", "A8", "", "", "E7", "", "A9", "A10", "D10", "F11", "D8", "D9", "", "", "A7", "")
'A B C D E F G H I J K L M N O P Q
で、各列をどのセルに参照させるか、指定してください。
'------
Sub Schedule()
Dim i As Long, ii As Long
Dim MxR As Long, MyR As Long, MyCnt As Long
Dim MyCell As String
Dim tbl As Variant, MyCA As Variant
Const OFR As Long = 7
Const RC As Long = 5
MyCA = Array("", "", "A8", "", "", "E7", "", "A9", "A10", "D10", "F11", "D8", "D9", "", "", "A7", "")
'A B C D E F G H I J K L M N O P Q
With Sheets("Sheet1")
tbl = .Range("A1:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
With Sheets("Sheet5")
For i = 2 To UBound(tbl, 1)
If tbl(i, 1) = "○" Then
MyCnt = Application.CountIf(.Range("D:D"), tbl(i, 4))
If MyCnt > 0 Then '◆データがすでにあった場合
If MsgBox("転記済みデータです。" & vbLf & _
vbTab & tbl(1, 4) & vbTab & tbl(i, 4) & vbLf & _
vbTab & tbl(1, 9) & vbTab & tbl(i, 9) & vbLf & _
vbTab & tbl(1, 11) & vbTab & tbl(i, 11) & vbLf & _
"上書きしますか？", vbYesNo) = vbYes Then
'上書き
MyR = Application.Match(tbl(i, 4), .Range("D:D"), 0)
For ii = 1 To UBound(tbl, 2)
.Cells(MyR, ii).Value = tbl(i, ii)
Next
End If
Else '◆データがまだ無かった場合
'転記
MxR = .Range("A" & Rows.Count).End(xlUp).Row + 1
For ii = 1 To UBound(tbl, 2)
.Cells(MxR, ii).Value = tbl(i, ii)
Next
'参照
MyCnt = Application.CountIf(.Range("P:P"), tbl(i, 16)) - 1
MyR = MyCnt * RC
For ii = 0 To UBound(MyCA, 1)
If MyCA(ii) <> "" Then
MyCell = .Name & "!" & Cells(MxR, ii + 1).Address(0, 0)
Sheets(tbl(i, 16)).Cells(MyCnt * RC + 1, 1).Range(MyCA(ii)).Value = _
"=IF(" & MyCell & "="""",""""," & MyCell & ")"
End If
Next
End If
End If
Next
End With
MsgBox "処理が終了しました。"
End Sub
'------
それから、返信は下のコメント欄から行ってもらうと 既存の書き込みとの間に勝手に水平線が引かれるので 便利だと思います。 [返信・編集]から返信を行う場合、半角「-」を四つ入れて 水平線が引かれる様にして下さい。
(HANA)
＞転記先として、指定されているセル以外は 何も入力は無いのでしょうか？
sheet2からsheet4は以下のようなガントチャートになっています。
＞それから、何か通し番号の様なものは無いのでしょうか？
データにはそれぞれ受注番号や工事番号がありますが、
通し番号のような連番になった値はありません。
＞また、Sheet1のデータは
＞B列〜P列まで…日付等のデータが入っています。 ＞と言う事ですが、データが入っていない可能性もありますか？ 列によってはデータの入っていないものもあります。
Sheet1とSheet2〜Sheet4の現在の状況です。
sheet2から4に転記するデータに※を付けました。
sheet1
A…フラグ
B…受注日付※
C…受注番号※
D…工事番号※
E…担当者番号
F…担当者名※
G…納期
H…件目コード※
I…件名
J…型番※
K…数量※
L…得意先名※
M…備考※
N…プロジェクトコード
O…プロジェクトコード2※
P…シート名
Q…作成納期※
sheet2からsheet4
A〜K…工事番号の内容を表示
L〜NM…カレンダー表示
1〜6行目…タイトルやコメント入力ボックス等
A〜K
H列は項目名としてすでに入力されていて、
A、DはSheet1からの転記の値を入れたい場所、
IからKは日付を入れるとLからのカレンダー部分に色が付くようになっています。
線で囲まれた部分が工事番号1件分を表示する行になり、
これを100件分用意してあります（506行まで）
本日教えていただいたコードでやってみたいと思います。
夜のご報告になりますが、またよろしくお願いいたします。
（苦戦4日目）
シートの状態がクリアになりました。ありがとうございます。
＞＞何か通し番号の様なものは無いのでしょうか？ と言ったのは、Sheet1の方のデータの事ではなく Sheet2〜Sheet4の ＞これを100件分用意してあります（506行まで） こちらの表内の事でした。
7:11の範囲のどこかに「1」 12:16の範囲のどこかに「2」 17:21の範囲のどこかに「3」 と入ってる様なセルがあるかどうか知りたかったのですが ご説明いただいた項目を見る限り、なさそうですね。。。
ちなみに、A列に工事番号（重複有無を確認する時キーになる項目）と その他の項目が一緒に入る様ですが これらが重複する可能性は有りますか？
無いのなら、A列の中から工事番号のセルを選んで確認 なんて面倒な事をしなくても良いですよね。
もう一つ、今後の可能性として 「結局、どの様なデータが表(Sheet2〜4)に有るか 一覧で見たい or 集計したい」 と言った事は無いでしょうか？
こちらも無いのなら、Sheet5は重複確認に使用するだけのデータ （今は、すべての項目を転記して ここからSheet2〜4に参照させてますが Sheet2〜4には、やはり直接データを入れて 工事番号だけSheet5にも入れる） にしても良いのかな。。。と思ったり。
(HANA)
sheet2〜sheet4だったのですね。
おっしゃる通りで、通し番号はありません。
＞ちなみに、A列に工事番号（重複有無を確認する時キーになる項目）と
＞その他の項目が一緒に入る様ですが
＞これらが重複する可能性は有りますか？
こちらの件ですが、例えばA列の工事番号がS961000010だとします。
その値が他の項目でダブっているということはないか？
という解釈であっていますでしょうか？
もしそうでしたら…重複はありません。
また、今後の可能性の件ですが、
そういった要望はありません。
取り急ぎ返信いたします。
夜、参ります！
（苦戦４日目）
＞その値が他の項目でダブっているということはないか？ ＞という解釈であっていますでしょうか？ はい、あってます。
＞また、今後の可能性の件ですが、 ＞そういった要望はありません。
でしたら、Sheet5を作って参照させるのは トラブルにつながりそうなので。。。 直接値を埋め込む方向にします。
コードは変更になりますので、上のは無視して下さい。
あと、返信は夜で良いですので。 とりあえず、新しいコードです。
なんかごちゃごちゃしてますが。。。
'------
Sub Schedule1()
Dim i As Long
Dim DtR As Long, StR As Long, MyCnt As Long
Dim Tbl As Variant, MyCA As Variant
Const OFR As Long = 7
Const RC As Long = 5
MyCA = Array("", "", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "H7")
'A B C D E F G H I J K L M N O P Q
With Sheets("Sheet1")
Tbl = .Range("A1:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
For i = 2 To UBound(Tbl, 1)
If Tbl(i, 1) = "○" Then
With Sheets(Tbl(i, 16))
MyCnt = Application.CountIf(.Range("A:A"), Tbl(i, 4))
If MyCnt > 0 Then '◆データがすでにあった場合
If MsgBox("転記済みデータです。" & vbLf & _
vbTab & Tbl(1, 4) & vbTab & Tbl(i, 4) & vbLf & _
vbTab & Tbl(1, 9) & vbTab & Tbl(i, 9) & vbLf & _
vbTab & Tbl(1, 11) & vbTab & Tbl(i, 11) & vbLf & _
"上書きしますか？", vbYesNo) = vbYes Then
'上書き
DtR = Application.Match(Tbl(i, 4), .Range("A:A"), 0)
StR = DtR - OFR
Call 転記(MyCA, Tbl, i, StR)
End If
Else '◆データがまだ無かった場合
'転記
DtR = Application.Max(OFR, .Range("A" & Rows.Count).End(xlUp).Row)
StR = Int((DtR - OFR + 1) / RC) * RC
Call 転記(MyCA, Tbl, i, StR)
End If
End With
End If
Next
MsgBox "処理が終了しました。"
End Sub
'------
Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long)
Dim i As Long
For i = 0 To UBound(MyCA, 1)
If MyCA(i) <> "" Then
Sheets(Tbl(MyR, 16)).Range(MyCA(i)).Offset(StR).Value = Tbl(MyR, i + 1)
End If
Next
End Sub
'------
(HANA)
一部、私の説明に不備があり以下のように書き換えを行いました。
MyCA = Array("", "I7", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "J7")
'A B C D E F G H I J K L M N O P Q
2点伺いたいのですが、
新規に転記する場合に上書きと同じようにメッセージを出したいのですが、
どのようにすればいいでしょうか？
（やってみたのですが、End Withに対するWithがありません、と出てしまいました）
次に、
現在テストデータとして5つ入っています。
2行目に〇のフラグを立てた後、実行→転記されました。
次の日を想定して5行目にフラグを立て実行→転記されませんでした。
2行目のデータを上書きしますか？のメッセージが出て「いいえ」選択、
With Sheets(Tbl(i, 16))
↑ここのコードで実行時エラー、インデックスが有効範囲にありません。
となってしまいました。
これを回避するにはどうしたらいいでしょうか？
（苦戦４日目）
先程の二つ目の質問ですが、
またしても私のミスでした！
シートが作成できていませんでした！！
本当に申し訳ありません。
完璧です。失礼しました。
（苦戦４日目）
sheet2から4への転記ですが、
sheet1のデータに〇が二つ付いている状態で、
その二つのが共にP列のシート名が同じ時、
転記先の二つ目のデータに受注日付と作成納期が転記されません。
sheet1のB列の受注日付→sheet2から4のI12
sheet1のQ列の作成納期→sheet2から4のJ12
質問ばかりで申し訳ございませんが、
この点も教えていただきたくお願いいたします。
（苦戦４日目）
確認ありがとうございます。 思いつく限りの色々なパターンで試してみてください。
＞転記先の二つ目のデータに受注日付と作成納期が転記されません。 に関してですが、その様に成るテストデータを エクセルからコピーして、こちらに貼り付けて貰えますか？
その際、レイアウトが崩れてもかまわずそのまま投稿して下さい。
(HANA)
エクセルからコピーして、こちらに貼り付けて
とありますが、どういうことをすればいいでしょうか？
sheet2でいいのでしょうか？
（苦戦４日目）
いや、Sheet1のデータの事です。
こちらで作ったデータでは特に問題無く動くので [A] [B] [C] [D] [E] [F] [G] [H] [I] [J] [K] [L] [M] [N] [O] [P] [Q] [1] フラグ 受注日付※ 受注番号※ 工事番号※ 担当者番号 担当者名※ 納期 件目コード※ 件名 型番※ 数量※ 得意先名※ 備考※ プロジェクトコード プロジェクトコード2※ シート名 作成納期※ [2] ○ I7 A9 A7-1 D7 A10 A11 D10 A8 D8 D9 Sheet2 J7 [3] ○ I7 A9 A7-1 D7 A10 A11 D10 A8 D8 D9 Sheet3 J7 [4] ○ I12 A14 A12-2 D12 A15 A16 D15 A13 D13 D14 Sheet2 J12 [5] こんな単純なデータです。
新しいシートを用意して ↑のデータをコピーして、 A1セル上で右クリック→形式を選択して貼り付け→テキスト で貼り付けてみて下さい。 ブラウザ上ではずれて表示されていると思いますが きちんとエクセルのセル内にデータが収まると思います。
そちらで試しているデータを、エクセルからコピーして 投稿してください。
また、↑で載せたデータでは思ったセルに結果が表示されるか やっぱり駄目なのか 合わせて教えてもらえると良いと思います。
(HANA)
まず、貼付を。 こういうことで良かったでしょうか？ これからHANAさんのデータで確認を取ります。
クリックで工程表転記フラグが立ちます 受注日付 受注番号 工事番号 担当者ｺｰﾄﾞ 担当者名 納期 件名コード 件名 型番 数量 得意先名１ 備考 ﾌﾟﾛｼﾞｪｸﾄﾒｲﾝｺｰﾄﾞ ﾌﾟﾛｼﾞｪｸﾄﾒｲﾝｺｰﾄﾞ2 Sheet名 作成納期(年月日) ○ 2013/6/21 13633 S960600148 16 伊藤 茂 2013/7/5 585096890000 (S/??1568) 工事 1 ああああ株式会社 齋藤 様 19960200 200 工程表_2部200 2013/7/4 ○ 2013/6/21 13645 S960600149 25 大川 勝 2013/8/9 900400140558 U5 1 いいいいい株式会社 名古屋研究所 19960100 100 工程表_1部100 2013/8/9 2013/6/21 13645 S960600150 25 大川 勝 2013/8/9 910410100009 0C 699-U 0 いいいいい株式会社 名古屋研究所 19960100 100 工程表_1部100 2013/8/9 ○ 2013/6/21 13645 S960600151 25 大川 勝 2013/8/9 910410008000 改修工事 0 いいいいい株式会社 名古屋研究所 19960100 100 工程表_1部100 2013/8/9 ○ 2013/6/21 13648 S960600152 42 佐藤 究 2013/6/27 585096830000 瑕疵工事 1 うう株式会社 藤原様分 19960200 200 工程表_2部200 2013/6/25
（苦戦４日目）
HANAさま HANAさまのデータでやってみました。 やはり2つめのフラグの日付の転記がされていないようです。 よろしくお願いいたします。 （苦戦４日目）
データありがとうございます。 貰ったデータは、こちらではうまくいくので なんですかね。。。
そちらで試しているコードを 貼り付けてみて貰えますか？
(HANA)
コードです。
Sub Schedule1()
Dim i As Long
Dim DtR As Long, StR As Long, MyCnt As Long
Dim Tbl As Variant, MyCA As Variant
Const OFR As Long = 7
Const RC As Long = 5
MyCA = Array("", "I7", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "J7")
'A B C D E F G H I J K L M N O P Q
With Sheets("受注データ")
Tbl = .Range("A1:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
For i = 2 To UBound(Tbl, 1)
If Tbl(i, 1) = "○" Then
With Sheets(Tbl(i, 16))
MyCnt = Application.CountIf(.Range("A:A"), Tbl(i, 4))
If MyCnt > 0 Then '◆データがすでにあった場合
If MsgBox("転記済みデータです。" & vbLf & _
vbTab & Tbl(1, 4) & vbTab & Tbl(i, 4) & vbLf & _
vbTab & Tbl(1, 9) & vbTab & Tbl(i, 9) & vbLf & _
vbTab & Tbl(1, 11) & vbTab & Tbl(i, 11) & vbLf & _
"上書きしますか？", vbYesNo) = vbYes Then
'上書き
DtR = Application.Match(Tbl(i, 4), .Range("A:A"), 0)
StR = DtR - OFR
Call 転記(MyCA, Tbl, i, StR)
End If
Else '◆データがまだ無かった場合
'転記
DtR = Application.Max(OFR, .Range("A" & Rows.Count).End(xlUp).Row)
StR = Int((DtR - OFR + 1) / RC) * RC
Call 転記(MyCA, Tbl, i, StR)
End If
End With
End If
Next
MsgBox "処理が終了しました。"
End Sub
'------
Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long)
Dim i As Long
For i = 0 To UBound(MyCA, 1)
If MyCA(i) <> "" Then
Sheets(Tbl(MyR, 16)).Range(MyCA(i)).Offset(StR).Value = Tbl(MyR, i + 1)
End If
Next
End Sub
お手数をおかけして申し訳ございません。 よろしくお願いいたします。 （苦戦４日目）
う〜〜む、問題無いですねぇ。
ちょっと面倒ですが、Sub転記のコードの
Sheets(Tbl(MyR, 16)).Range(MyCA(i)).Offset(StR).Value = Tbl(MyR, i + 1)
の行の上に
If i = 1 Or i = 16 Then
MsgBox MyR & "件目のデータ" & vbLf & _
"シート名：" & Tbl(MyR, 16) & vbLf & _
"セル番地：" & Range(MyCA(i)).Offset(StR).Address(0, 0) & vbLf & _
"項目：" & Tbl(1, i + 1) & vbLf & _
"値：" & Tbl(MyR, i + 1)
End If
をいれて、どの様なメッセージが表示されるか確認してみて下さい。
一行に2回。合計8回 メッセージボックスが表示されると思いますが。
(HANA)
＞一行に2回。合計8回 メッセージボックスが表示されると思いますが。
HANAさまのデータでやっています。 データは3件ですよね？ 1行に2回
2件目のデータ I7 2件目のデータ J7
3件目のデータ I7 3件目のデータ J7
4件目のデータ I12 4件目のデータ J12
と出ています。 もう一度元々の自分のデータで行ってみます。 （苦戦４日目）
そうですね。 私のデータでしたら、3件なので 6回出ると思います。
問題は 4件目のデータと表示される時なんですよね？ 4件目のデータ シート名：Sheet2 セル番地：I12 項目：受注日付※ 値：I12 とメッセージが表示されたら、 Sheet2のI12セルに「I12」とデータが入っていると思いますが。。。 どうなっていますか？ もう一度セルの値を確認してみて下さい。
(HANA)
再度試してみました。 I12,J12とメッセージでは出ているのですが、 転記されていない状態です。
遅い時間に申し訳ありません。 また後日で構いませんので、ご教示お願いいたします。 （苦戦４日目）
メッセージは、私が載せた物と同じものが表示されますか？
コードは正常に終了するのですよね？
その後単独で
Sub 確認1()
Dim myTxt As String
myTxt = Sheets("Sheet2").Range("I12").Value
If myTxt = "" Then
MsgBox "入力無し｡"
Else
MsgBox "入力あり。 " & myTxt
End If
End Sub
を実行すると、どうなりますか？
(HANA)
コードは正常に終了します。 確認1を実行すると入力なしとメッセージが出ました。 （苦戦４日目）
Sheet2のA列とD列には転記されてるんですよね？
試しに、受注日付を工事番号のセル。 工事番号を受注日付のセル。 に転記される様にすると、どうなりますか？
また、今は２件のデータで試して貰っていますが ３件になった場合は、どうなるのでしょう？
(HANA)
返信遅れて申し訳ありません。
＞試しに、受注日付を工事番号のセル。 工事番号を受注日付のセル。 ＞に転記される様にすると、どうなりますか？
＞また、今は２件のデータで試して貰っていますが ＞３件になった場合は、どうなるのでしょう？
値を変える、データを増やす、 共にやってみましたがやはり一件目のデータしか転記されず…です。
（苦戦４日目）
色々お手数をおかけして申し訳ありません。 HANAさまからのデータで、新規作成（sheet2、sheet3を何もない状態）で試したところ、 問題なく転記されていました。
やはり私が元々作成したsheet2から4が問題を起こしているようです。 今試したデータを元に本日再作成して夜、ご報告に参ります！
（苦戦４日目）
[A] [B] [C] [D] [E] [F] [G] [H] [I] [J] [K] [L] [M] [N] [O] [P] [Q] [1] フラグ 受注日付※ 受注番号※ 工事番号※ 担当者番号 担当者名※ 納期 件目コード※ 件名 型番※ 数量※ 得意先名※ 備考※ プロジェクトコード プロジェクトコード2※ シート名 作成納期※ [2] ○ I7 A9 A7-1 D7 A10 A11 D10 A8 D8 D9 Sheet2 J7 [3] ○ I7 A9 A7-1 D7 A10 A11 D10 A8 D8 D9 Sheet3 J7 [4] ○ I12 A14 A12-2 D12 A15 A16 D15 A13 D13 D14 Sheet2 J12
HANAさま 取り急ぎご報告です。 セルの結合のせいで起こってしまったようです! 結合を解除すると問題なく動きました。 夜また参ります。 お手数をお掛けしてしまい申し訳ございませんでした。 （苦戦４日目）
セルの結合ですね。
Sub 転記の↓の行を
Sheets(Tbl(MyR, 16)).Range(MyCA(i)).Offset(StR).Value = Tbl(MyR, i + 1)
こんな感じで変更してみて下さい。↓
Sheets(Tbl(MyR, 16)).Range("A1").Offset(StR).Range(MyCA(i)).Value = Tbl(MyR, i + 1)
~~~~~~~~~~~~~~~~~~~~~~~~
.Range("A1")を追加して、.Offset(StR)の位置を変更。
(HANA)
そういえば、新規の時もメッセージを出すんでしたね。
コード内の
msgA = Array("D1", "I1", "K1")
で、メッセージとして表示したい項目がある先頭セルを指定して下さい。
'------
Sub Schedule3()
Dim i As Long, ii As Long
Dim DtR As Long, StR As Long, MyCnt As Long, msgC As Long
Dim IC As Long
Dim Tbl As Variant, MyCA As Variant, msgA As Variant
Dim msg As String
Const OFR As Long = 7
Const RC As Long = 5
msgA = Array("D1", "I1", "K1")
MyCA = Array("", "I7", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "J7")
'A B C D E F G H I J K L M N O P Q
With Sheets("受注データ")
Tbl = .Range("A1:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
For i = 2 To UBound(Tbl, 1)
If Tbl(i, 1) = "○" Then
For ii = 0 To UBound(msgA, 1)
msgC = Range(msgA(ii)).Column
msg = msg & vbLf & vbTab & Tbl(1, msgC) & vbTab & Tbl(i, msgC)
Next
With Sheets(Tbl(i, 16))
MyCnt = Application.CountIf(.Range("A:A"), Tbl(i, 4))
If MyCnt > 0 Then '◆データがすでにあった場合
'上書き時
msg = "転記済みデータです。" & msg & vbLf & _
"上書きしますか？"
IC = vbCritical
DtR = Application.Match(Tbl(i, 4), .Range("A:A"), 0)
StR = DtR - OFR
Else '◆データがまだ無かった場合
'新規登録時
msg = "新規データです。" & msg & vbLf & _
"登録しますか？"
IC = vbQuestion
DtR = Application.Max(OFR, .Range("A" & Rows.Count).End(xlUp).Row)
StR = Int((DtR - OFR + 1) / RC) * RC
End If
If MsgBox(msg, vbYesNo + IC) = vbYes Then
Call 転記(MyCA, Tbl, i, StR)
End If
End With
msg = ""
End If
Next
MsgBox "処理が終了しました。"
End Sub
'------
Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long)
Dim i As Long
For i = 0 To UBound(MyCA, 1)
If MyCA(i) <> "" Then
Sheets(Tbl(MyR, 16)).Range("A1").Offset(StR).Range(MyCA(i)).Value = Tbl(MyR, i + 1)
End If
Next
End Sub
'------
(HANA)
コード少し変更して、マクロ名も Schedule2 → Schedule3 に変更しました。 Schedule2でテスト済でしたら、すみませんが Schedule3でもう一度確認して下さい。
(HANA)
HANAさま 色々と本当にありがとうございます。 先程から動かしてみています。順調です！！ 先のレスで書いていただいたメッセージ表示の件ですが、 それぞれのセルの前に昨夜のテスト時のような形にしたいと思って書き換えてみたのですが、 見当違いなところをいじってしまったようで思った形になりませんでした。
D1の前に"工事番号："という文言をプラスしたいのです。
"○○："&ではないのでしょうか？
ご教示よろしくお願いいたします。
（苦戦４日目）
D1には、何と入っていて メッセージに 何と表示されるのを 何と言う表示に変えたいのですか？
(HANA)
転記済データです。 S961000251 （D1の値です） ○○○工事 （I1の値です） 1 （K1の値です） 上書きしますか？
希望 転記済データです。 工事番号：S961000251 （D1の値です） 件 名：○○○工事 （I1の値です） 数 量：1 （K1の値です） 上書きしますか？
以上のようにしたいです。 よろしくお願いいたします。 （苦戦４日目）
えっと、載せてもらったサンプルデータは 1行目に見出しがありますが 実際は無いのですか？
(HANA)
見出しあります… 項目がある先頭セル、でしたね。 すみません。 D2,I2,K2になります。 （苦戦４日目）
2行目に見出しが入っていて 3行目からデータですか？
そしたら、
'------
Sub Schedule4()
Dim i As Long, ii As Long
Dim DtR As Long, StR As Long, MyCnt As Long
Dim msgR As Long, msgC As Long
Dim IC As Long
Dim Tbl As Variant, MyCA As Variant, msgA As Variant
Dim msg As String
Const OFR As Long = 7
Const RC As Long = 5
msgA = Array("D2", "I2", "K2")
MyCA = Array("", "I7", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "J7")
'A B C D E F G H I J K L M N O P Q
With Sheets("受注データ")
Tbl = .Range("A1:Q" & .Range("A" & Rows.count).End(xlUp).Row).Value
End With
msgR = Range(msgA(0)).Row
For i = msgR + 1 To UBound(Tbl, 1)
If Tbl(i, 1) = "○" Then
For ii = 0 To UBound(msgA, 1)
msgC = Range(msgA(ii)).Column
msg = msg & vbLf & vbTab & Tbl(msgR, msgC) & "：" & vbTab & Tbl(i, msgC)
Next
With Sheets(Tbl(i, 16))
MyCnt = Application.CountIf(.Range("A:A"), Tbl(i, 4))
If MyCnt > 0 Then '◆データがすでにあった場合
'上書き時
msg = "転記済みデータです。" & msg & vbLf & _
"上書きしますか？"
IC = vbCritical
DtR = Application.Match(Tbl(i, 4), .Range("A:A"), 0)
StR = DtR - OFR
Else '◆データがまだ無かった場合
'新規登録時
msg = "新規データです。" & msg & vbLf & _
"登録しますか？"
IC = vbQuestion
DtR = Application.Max(OFR, .Range("A" & Rows.count).End(xlUp).Row)
StR = Int((DtR - OFR + 1) / RC) * RC
End If
If MsgBox(msg, vbYesNo + IC) = vbYes Then
Call 転記(MyCA, Tbl, i, StR)
End If
End With
msg = ""
End If
Next
MsgBox "処理が終了しました。"
End Sub
'------
Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long)
Dim i As Long
For i = 0 To UBound(MyCA, 1)
If MyCA(i) <> "" Then
Sheets(Tbl(MyR, 16)).Range("A1").Offset(StR).Range(MyCA(i)).Value = Tbl(MyR, i + 1)
End If
Next
End Sub
'------
でやってみて下さい。
(HANA)
説明が下手で申し訳ないです。 HANAさんのおっしゃっていることを理解出来ていないのだと思います…。 1行目に項目、2行目からデータが入っています。
メッセージが表示された時に現在はセルの値が出るようになっていますが、 その値の前に項目名を表示させたいのです…。
転記済データです。
↓受注データの項目名（これを入れたいのです） ↓受注データの転記した値 工事番号： S961000251 （D1の値です） 件 名： ○○○工事 （I1の値です） 数 量： 1 （K1の値です） 上書きしますか？
（苦戦４日目）
1行目に項目が入っているんですか？
じゃあ、「工事番号」って入っているセルをアクティブにして 数式バーに「工事番号」と表示されることを確認してから 数式バーの左側にある、名前ボックスに表示されているセル番地を教えて下さい。
コードは当初から 項目名も表示させる様になっています。
それが表示されていないのなら 項目名が入っている予定のセルに 項目名が入っていないのでしょう。
まずは、そちらで使っている受注データシートと 同じシートがこちらで作成できるだけの情報を 載せてもらえたらと思います。
ちなみに、先に載せてもらったサンプルデータを置いて Schedule4 を実行してもらうと
転記済データです。 S960600148 ： S960600149 (S/??1568) 工事 ： U5 1 ： 1 上書きしますか？
って表示されますか？
(HANA)
HANAさま 申し訳ありません。 きちんと出ていました。 私の方で途中でsheet1の1行目にマクロの実行ボタンを置く場所を作りたくて、 1行目を使用してしまったデータでやってしまっていたのが原因です。 キチンと説明出来なくてお手数をおかけしてしまいました。 本当に申し訳ありません。 HANAさんがおっしゃっている通りに動きます。 理想通りです！ 本当にありがとうございました！
あと1つ伺いたいのですが、 新規転記した際に、別のBOOK（原本となるものを作ってあります）に同じように (セル番地は異なりますが、転記するデータは同じです） 転記し、 sheet1のD列の工事番号の名前で保存したい場合、 以下、教えていただいたコードのmsg = ""とEnd Ifの間にコードを入れるので大丈夫でしょうか？ コードを入れる場所がよく分からず、重ねての質問で申し訳ありませんがご教示お願いいたします。
msg = ""
End If
Next
MsgBox "処理が終了しました。"
End Sub
'------
Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long)
（苦戦４日目）
問題点が見つかりましたか。良かったです。
コードの方ですが、最新バージョン（Schedule4）を使ってください。
msgA = Array("D2", "I2", "K2")
では、見出しがある行（タイトル行）のセルを指定してください。
１行目を空行にして、２行目にタイトルがあるなら、D2,I2,K2 を指定 １行目からタイトルがあるなら、D1,I1,K1 ですね。
追加のご質問に関しては、 たぶん、５件新規登録したら ブックを５つ作るのですよね？ で、上書きの場合は 作らない。
であれば、そんなに単純ではないですね。 コードも少し変更しないといけないです。
まぁ、まずは ＞あと1つ伺いたいのですが〜〜〜 のご説明は曖昧に感じますので もう少し詳しく教えてください。
＞ 転記し、sheet1のD列の工事番号の名前で保存 のコード自体はできるんですかね？
(HANA)
HANAさま コードを最新版にし、動作確認を完了しました。 改めて本当にありがとうございました。
追記の件です。 HANAさんのおっしゃる通り、 今回の動作で5つフラグが立ってすべて新規登録したのだとしたら、 5つ新規にブックを作り、上書きの場合は作らないということです。
やりたいことの目的としては、 受注データのシートA列にフラグを立てたD列の工事番号の詳細なスケジュールを組めるものを作りたい。 動作としては、 sheet2からsheet4のA7、A12、A17（以降+5）の工事番号をクリックすると、 その工事番号のついたBOOKへリンクする。
その動作を行いたいので、今回作って頂いたコードに、 新規転記を行ったデータに対して、 フラグの立ったD列の名前で詳細スケジュールの原本を利用して、 新規BOOKを作成したい。
以上のようなことです。
新規のBOOKを原本を利用して作成すること、 またsheet2から4のA7…のセルと新規作成したBOOKを作成することのコードについては、 後者の方は参考書のコードが利用出来るのではないかと考えております。 原本の方は未だ参考書とネットで調べ中といったところです…。
また後から今回のコードに影響が出てお手間を取らせてしまうと大変なので、 今伺いたいのですが、 現在、受注データをCSVのデータをコピー、加工して持ってきているのですが、 （この動作を毎日行い受注データは累積していきます） A列にフラグを立て、翌日を想定して動かすと前日に立てたフラグが消えてしまいます。 フィルタ部分がおかしいのだと思うのですが、 以下、受注データを取り込むコードになります。 なにしろ自分でやったものなのでめちゃくちゃだと思います。 記録マクロが混在しています。 この問題点を回避しないとまずいと思っているのですが、添削していただけないでしょうか？
csvデータ（1行目は項目名、2行目以降にデータです） A…受注日付 B…受注番号 C…工事番号 D…担当者番号 E…担当者名 F…件名コード G…件名 H…型番 I…数量 J…納期 K…得意先名 L…備考 M…プロジェクトコード N…作成納期
Sub 受注データ取込_Click()
Dim myCnc1 As String
Dim myCnc2 As String
Dim myFileName As String
Dim sheet1 As Worksheet
Sheets("受注データ").Cells.Clear
'Columns("B:Q").Clear
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
myFileName = "00_工程表_受注データ.csv"
Set sheet1 = Worksheets(2)
sheet1.Activate
myCnc1 = "TEXT;"
myCnc2 = ThisWorkbook.Path & "\" & myFileName
With ActiveSheet.QueryTables.Add( _
Connection:=myCnc1 & myCnc2, _
Destination:=Range("B2"))
.TextFilePlatform = 932
.TextFileCommaDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.Refresh
End With
'Columns("A:A").Insert
Columns("K:K").Select
Selection.Cut
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
FieldInfo:=Array(1, 5)
Columns("G:G").Select
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
FieldInfo:=Array(1, 5)
Columns("O:O").Select
Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
FieldInfo:=Array(1, 5)
Dim r As Long
r = Range("E" & Rows.Count).End(xlUp).Row
Columns("E:E").Insert
Range("E2:E" & r).FormulaR1C1 = "=LEFT(RC[-1],10)"
Range("E2:E" & r).Value = Range("E2:E" & r).Value
Range("D2").Copy Range("E2")
Columns("D:D").Delete
Columns("H:H").NumberFormatLocal = "0_ "
Columns("J:J").NumberFormatLocal = "0_ "
Columns("O:O").Insert
Range("O2:O" & r).FormulaR1C1 = "=Right(RC[-1],3)"
Range("O2:O" & r).Value = Range("O2:O" & r).Value
Range("N2").Copy Range("O2")
Range("O2") = Range("N2") + "2"
Columns("P:P").Insert
Range("P3:P" & r).FormulaR1C1 = "=VLOOKUP(RC[-1],非稼働日!R1C3:R5C4,2,0)"
Range("P3:P" & r).Value = Range("P3:P" & r).Value
Range("P2") = Range("P2") + "Sheet名"
Range("A2").Select
Dim myRng1 As Range
Dim myRng2 As Range
Dim mySht As Worksheet
Set myRng1 = _
ActiveSheet.Range("D2").CurrentRegion
With myRng1
.AutoFilter Field:=3, Criteria1:="=J*"
Set myRng2 = .SpecialCells(xlCellTypeVisible)
.AutoFilter
myRng2.EntireRow.Hidden = True
On Error Resume Next
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
myRng2.EntireRow.Hidden = False
End With
Set myRng1 = Nothing
Set myRng2 = Nothing
Range("B2:Q2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Columns("A:A").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
Cells(2, 1) = "Ｗクリックで工程表転記フラグが立ちます"
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Columns("A:A").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("B:Q").AutoFit
Range("A2").Select
End With
End Sub
以下、無関係かもしれませんが、フラグを立てるコードです。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const rng As String = "A3:A100000" '処理対象のセル範囲
If Not Application.Intersect(Target, Range(rng)) Is Nothing Then
If Target.Value = "" Then
Target.Value = "○"
Else
Target.ClearContents
End If
End If
End Sub
本当に色々とお伺いばかりで申し訳ございませんが、 HANAさんのおかげで思い描いていたものが出来感謝しております。 ご教示の程、よろしくお願いいたします。
（苦戦４日目）
＞ 新規のBOOKを原本を利用して作成すること、 これは、 原本ブックを開いて、名前を付けて保存する と言う方向で調べてみて下さい。
実際に、Sheet2〜Sheet4に転記するのは Call 転記(MyCA, Tbl, i, StR) の部分を通った時です。
＞工事番号をクリックすると、その工事番号のついたBOOKへリンクする。 でしたら、これより前に 詳細スケジュールのブックは保存しておくのが良い （しておかないとダメ だったかな？）と思います。
また、現在出来ているコードに組み込む事になると思いますので 連携できる様に考えてみて下さい。
＞A列にフラグを立て、翌日を想定して動かすと前日に立てたフラグが消えてしまいます。 に関してですが、コードがどの順番で何を行っているのか 簡単に説明してもらえませんか？
＞（この動作を毎日行い受注データは累積していきます）
どこに累積されていくのですか？
最初の方に Sheets("受注データ").Cells.Clear ってなっているので
全てのセルの値を消してしまっていると思いますが。。。
とりあえず「ステップインで実行」を身に付けてみられると良いと思います。 コードを実行する時に、[実行(R)]ではなく[ステップイン(S)]を選ぶか VBE(コードを書いている方のウィンドウ)の実行させたいコード内にカーソルがある状態で [F8]を押すか、メニューのデバッグ(D)→ステップイン(I) をしてもらうと [F8]を押す毎に、コードを一行ずつ実行させることが出来ます。
そしたら、どの時点で「○」が消えてしまうのか 確認出来ると思いますので 対策も考えられるようになると思います。
(HANA)
内容確認してみました。
「○」は消えずにどうなるのが希望でしょうか？
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
って所があるので、実行前にA10に「○」があっても
実行後は別の位置に移動してしまうと思います。
今日のデータは、昨日のデータの後ろに今日の情報が追加になったもの （一回付けた○の位置〜一度転記が必要だと判断したデータの位置〜は、変わらない）だから CSVを貼り付けて、必要なデータを抜き出したら 昨日と同じ位置に「○」がついていて欲しい
って事でしょうか？
簡単な変更で済むのは、A列の情報を先に写し取っておいて 最後に元に戻す事だと思います。
とりあえず、こんな感じにしてみましたが。
'------
Sub 受注データ取込_Click2()
Dim myCnc1 As String
Dim myFileName As String
Dim r As Long
Dim tbl As Variant
Sheets("受注データ").Activate
tbl = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
Cells.Clear
myFileName = "00_工程表_受注データ.csv"
myCnc1 = "TEXT;" & ThisWorkbook.Path & "\" & myFileName
With ActiveSheet.QueryTables.Add( _
Connection:=myCnc1, _
Destination:=Range("B2"))
.TextFilePlatform = 932
.TextFileCommaDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.Refresh
End With
r = Range("E" & Rows.Count).End(xlUp).Row
Columns("K:K").Cut
Columns("G:G").Insert Shift:=xlToRight
Range("B2:B" & r).TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, FieldInfo:=Array(1, 5)
Range("G2:G" & r).TextToColumns Destination:=Range("G2"), DataType:=xlDelimited, FieldInfo:=Array(1, 5)
Range("O2:O" & r).TextToColumns Destination:=Range("O2"), DataType:=xlDelimited, FieldInfo:=Array(1, 5)
Columns("E:E").Insert
Range("E2:E" & r).FormulaR1C1 = "=LEFT(RC[-1],10)"
Range("E2:E" & r).Value = Range("E2:E" & r).Value
Range("E2").Value = Range("D2").Value
Columns("D:D").Delete
Columns("H:H").NumberFormatLocal = "0_ "
Columns("J:J").NumberFormatLocal = "0_ "
Columns("O:O").Insert
Range("O2:O" & r).FormulaR1C1 = "=Right(RC[-1],3)"
Range("O2:O" & r).Value = Range("O2:O" & r).Value
Range("O2").Value = Range("N2").Value & "2"
Columns("P:P").Insert
Range("P3:P" & r).FormulaR1C1 = "=VLOOKUP(RC[-1],非稼働日!R1C3:R5C4,2,0)"
Range("P3:P" & r).Value = Range("P3:P" & r).Value
Range("P2").Value = "Sheet名"
With Range("B2:Q" & r)
.AutoFilter Field:=3, Criteria1:="<>J*"
On Error Resume Next
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
.Parent.AutoFilterMode = False
End With
With Range("B2:Q2")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = -0.249977111117893
End With
With .Font
.ThemeColor = xlThemeColorDark1
End With
End With
With Columns("A:A")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Color = -16776961
End With
End With
Range("A1").Resize(UBound(tbl, 1), 1).Value = tbl
Range("A2").Value = "Ｗクリックで工程表転記フラグが立ちます"
Columns("B:Q").AutoFit
Range("A2").Select
End Sub
'------
(HANA)
HANAさま、こんばんは。 レスが遅くなって申し訳ありません。 今日一日、〇が消えてしまうのをどうしたらいいか色々とやってみました。
＞今日のデータは、昨日のデータの後ろに今日の情報が追加になったもの ＞（一回付けた○の位置〜一度転記が必要だと判断したデータの位置〜は、変わらない）だから ＞CSVを貼り付けて、必要なデータを抜き出したら 昨日と同じ位置に「○」がついていて欲しい
＞って事でしょうか？
その通りです！ CSVに落とす際にシステムに受注番号を入力してその番号以降の件名を落として保存していました。 ですので、7/2が受注番号1〜10（仮定です）、7/3は1〜15という風に開始はいつも1でした。 これを1〜10、翌日は11〜15にした方がいいのか、悩んだまま作り始めてしまったのですが、 一度付けた〇はずっと付いていて欲しいのに、 どちらにしても同じシートで加工していると〇が消えてしまう訳で… うまく説明出来ないのですが、その回避方法が分からず悩んでいました。
本日色々とやってみたのですが、 CSVデータは1〜10、翌日は11〜15という方法で落とし、 CSVを加工する受注データのシートと本日分をコピペして〇を付けて転記する転記シートの二つに分ける、 この方法で実験をしていたところです。 まだ翌日を想定した動作確認は出来ていません。
HANAさんが教えてくださったものは早速明日やらせていただきます！ 原本を〜の方もネットで調べて実験したのですが、 思った通りにはできませんでした…
まずは〇の方を直して完成させたいと思います。 明日の夜ご報告に参りますので、お手数ですがまたよろしくお願いいたします。
（苦戦４日目）
そうですね。 ＞CSVデータは1〜10、翌日は11〜15という方法で落とし、 の方法が良いと思います。
ただ ＞CSVを加工する受注データのシートと本日分をコピペして〇を付けて転記する転記シートの二つに分ける、 この二つのシートの使いわけが良くわからないですが。。。
例えば ・今日のデータのA列に「○」を付けて 転記行を指示するシート ・今日までのデータを一覧でのけておくシート でしたら、理解しやすいのですが。
実際問題として、過去のデータが変わる事が有るのですか？ となると、Sheet2〜4のシートと 作成済みの スケジュール詳細管理ブック（？）の 二つのデータの変更が必要になりますよね？
Sheet2〜4のデータと、スケジュール詳細管理ブック(？）のデータが 一致しなくても良いんですかね？
受注データ取込_Click2のコードは、色々変更しましたが
Dim tbl As Variant
tbl = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
Range("A1").Resize(UBound(tbl, 1), 1).Value = tbl
の3行を削除してもらうと、同じ動きに成ると思いますので
やってみてください。
それから、話が続く様であれば ・Sheet2〜4 ・スケジュール詳細管理ブック（？） の、より現状に近い名前を教えて（つけて）もらえたらと思います。
「二兎を追うものは一兎も得ず」と言いますので ブックを作る方のコードは、一旦保留にしましょう。 で、今の問題が解決したら それに関する過去ログを御紹介出来ると思います。 そんなに珍しいご希望と言う訳ではないと思いますので。
(HANA)
おはようございます。
2つに分けたシートの使い分けについてですが、 ＞・今日までのデータを一覧でのけておくシート といった感じです。 〇を残したいのだから今日落とした分はそちらのシートに持っていき、 そこで〇を付ける→そして翌日はその最終行の次の空白行に貼付→〇をつける →転記のマクロを実行する。 これなら〇が残ると思い作成してみました。 実際、受注データに変更があったことはないのですが、 もしもあったら…ということで「上書きしますか？」とあったほうがいいのかと考えておりました。 スケジュール詳細管理ブック(以降、工事番号別ブック）の方の変更まで考えが及ばず… HANAさんのご指摘で気が付きました。 変更は本当に稀な事なので、今回そこは考えずに行きたいと思います。
またsheet2から4の名前はM列のプロジェクトコードの下三桁で三種類あります。 001,002,003としたいと思います。
スケジュール詳細管理ブックについては工事番号別ブックです。Jに9ケタの数字が足されたものです。
では、今日の夜また参ります！ 色々ありがとうございます。よろしくお願いいたします。
（苦戦４日目）
現在、もしも過去のデータに変更があった場合 そのデータを含めてCSVに落すわけではなく 使っているエクセルに登録されている情報を 自主的に直すのですよね？
でしたら 転記用データシートと、蓄積用データシートを作って 蓄積用データシートに、A列に「○」がついたものだけを蓄積していくのか 工事番号が「Jで始まるもの」をすべて蓄積していくのか 不明ですが 蓄積用データシートから、該当のデータを転記用データシートにコピーして データを変更し、A列に「○」を付ける。 今日処理すべきデータと合わせて処理をする。
とした方が、面倒でなくて良いと思いますが。
蓄積用データシートで、過去のもので転記済のものにすべて「○」がついている状態で そこに今日分のデータを入れて一緒に処理してしまうと 『上書きしますか？』メッセージが大量にでて 実際どれが本当に上書きが必要なデータなのか 分かりにくくなりませんか？
もちろん、 ・蓄積用データシートには「○」がついたものしか保存せず 転記が済んだらA列の「○」は削除する ・変更があった場合、該当のデータを変更し A列に「○」を付ける のでしたら、無駄なメッセージボックスも出なくなると思いますが。。。
＞001,002,003としたいと思います。 は、これらのシートの総称を教えてほしい と言ったつもりでした。 プロジェクトコードの下三桁は、何かを表しているのではないのですか？ 例えば、001は新設・002は改修・003はその他 みたいな感じで。 ・・・・となると、何っていうのがいいのか悩みますね。 プロジェクト区分別シート とか？ 担当部署を表しているなら、名前を付けるのも簡単だと思いますが。
先によくよく考えてから動き出した方が、無駄がないと思いますよ。 たぶん、受注データ取込_Click2のコードは無駄になっていると思いますし。
(HANA)
HANAさま レスが遅くなり申し訳ありません。 本日ちょっと要望が変わりまして…
まずお返事と新たな要望について書かせていただきます。
・過去のデータに変更があった場合について CSVには落とさず、転記後のシートを直接直します。
・蓄積用のデータシート（Sheet名「転記」）の何を残すか★
これについては本日要望がありまして、
Sheet：転記
A列の○も無印も全てのデータを一旦は残す。
B列の受注日付から30日経過したデータを削除したい。
○の付いたデータは上書はしないのでメッセージは消したい。
（HANAさんのおっしゃる通り大量に出てしまうので…）
新規のものだけ「登録しますか？」にしたい。★
・Sheet2から4の総称について
担当部署のコードと言えばいいのでしょうか…
こちらのシートに対しても本日新たな要望がありまして、
シートを2枚増やしたいとのことでした。
本日はこの作業に追われなんとかシートを2枚追加して、
転記するところまで動作確認いたしました。
転記のセル番号などは変更ありません。
現在のシート構成は以下の通りです。（画面左から）
シート名
1枚目/非稼働日
（このシートのA列に非稼働日の日付、C1:D7に受注データのシートのVLOOK用の表があります）
2枚目/受注データ（CSVデータを開いて加工するシートです）ボタンの名前は「受注データ取込」
3枚目/転記 ボタンの名前は「工程表に転記」→Sub Schedule4()です。
4枚目/1部100（1部が部署名、100が部署のコードです）
5枚目/1部100計画（本日要望のあった追加のシートです）
6枚目/2部200
7枚目/2部200計画（本日要望のあった追加のシートです）
8枚目/その他300-500
受注データと転記シートの構成は同じです。 シートを増やした後、動作確認して転記先のセルがずれていないか確認をとりました。 要望に沿ったものと考えると以下の流れになると思います。
1.受注データのシートにCSVデータを落とし加工する CSVデータは1〜10、翌日は11〜15という方法にする
2.転記シートに累積してデータをコピペする
3.転記シートの中から部署ごとのシートに登録したいものを選び転記シートA列に○のフラグをたてる
4.転記シートの「工程表に転記」で転記シートのP列のシート名の所へ各セルの値を転記
----------------------------------------------------------- これから進めなくてはいけないことは以下です。
5.4と同時に各部署のシートのA7（+5ずつ以降続きます。A12、A17）の 工事番号の名前で工事番号の詳細工程表を作成保存（カラの原本は用意済）
6.詳細工程表に転記シートの時と同じように転記（セル番号は違います）
7.全体の工程表と各工事番号の名前の付いた詳細工程表をハイパーリンクで飛ぶようにする
8.全体の工程表のA7のセルの値のブックを探し、 詳細工程表の日付が入っている各セルの値を転記
長くなってしまって申し訳ありません。 以上のようなことですので、転記シートのVBAを変更しなければならないと思うのですが… 上に書きました★〜★までの部分を教えていただけないでしょうか？
現在のコードです。
Sub Schedule4()
Dim i As Long, ii As Long
Dim DtR As Long, StR As Long, MyCnt As Long
Dim msgR As Long, msgC As Long
Dim IC As Long
Dim Tbl As Variant, MyCA As Variant, msgA As Variant
Dim msg As String
Const OFR As Long = 7
Const RC As Long = 5
msgA = Array("D2", "I2", "K2")
MyCA = Array("", "I7", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "J7")
'A B C D E F G H I J K L M N O P Q
With Sheets("転記")
Tbl = .Range("A1:Q" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
msgR = Range(msgA(0)).Row
For i = msgR + 1 To UBound(Tbl, 1)
If Tbl(i, 1) = "○" Then
For ii = 0 To UBound(msgA, 1)
msgC = Range(msgA(ii)).Column
msg = msg & vbLf & vbTab & Tbl(msgR, msgC) & "：" & vbTab & Tbl(i, msgC)
Next
With Sheets(Tbl(i, 16))
MyCnt = Application.CountIf(.Range("A:A"), Tbl(i, 4))
If MyCnt > 0 Then '◆データがすでにあった場合
'上書き時
msg = "転記済みデータです。" & msg & vbLf & _
"上書きしますか？"
IC = vbCritical
DtR = Application.Match(Tbl(i, 4), .Range("A:A"), 0)
StR = DtR - OFR
Else '◆データがまだ無かった場合
'新規登録時
msg = "新規データです。" & msg & vbLf & _
"登録しますか？"
IC = vbQuestion
DtR = Application.Max(OFR, .Range("A" & Rows.Count).End(xlUp).Row)
StR = Int((DtR - OFR + 1) / RC) * RC
End If
If MsgBox(msg, vbYesNo + IC) = vbYes Then
Call 転記(MyCA, Tbl, i, StR)
End If
End With
msg = ""
End If
Next
MsgBox "処理が終了しました。"
End Sub
'------
Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long)
Dim i As Long
For i = 0 To UBound(MyCA, 1)
If MyCA(i) <> "" Then
Sheets(Tbl(MyR, 16)).Range("A1").Offset(StR).Range(MyCA(i)).Value = Tbl(MyR, i + 1)
End If
Next
End Sub
'------
色々と申し訳ありませんが私の力では要望に応えられません。 どうぞよろしくお願いいたします。 （苦戦４日目）
＞・蓄積用のデータシート（Sheet名「転記」）の何を残すか★ ＞ ○の付いたデータは上書はしないのでメッセージは消したい。 でも、変更が有った場合は上書きするんですよね？
また、 ＞2.転記シートに累積してデータをコピペする ＞3.転記シートの中から部署ごとのシートに登録したいものを選び転記シートA列に○のフラグをたてる 処理する時も、転記シートのデータを先頭行から処理して行くのですよね？ 日に何件あるのか分からないですが、前日までのデータは必ず転記しないのに A列に「○」が付いているか。 ついていたら新規データかどうか。 確認が必要になりますよね？
これって、効率が悪く無いですか？
ご自身がやる時の事を考えながら「どの様にエクセルに作業させるか」を 考えてみたらどうでしょう？
「修正」も要るんですよね？
詳細工程表を作る所も 原本ブックを開く 名前をつけて保存する。 データを転記する。 だと、もう一度保存が必要ですよね？
原本ブックを開く データを転記する 名前をつけて保存する だと、３工程です。
「全体の工程表」ってのが、何の事か良く分からないのですが Sheet2から4の総称 の事ですか？ でも「全体」っていうと「全体」ですよね。。。
新規の時だけメッセージを出す様にするコードは Schedule,Schedule1 を良く確認して 変更してみて下さい。 この時はまだ Call 転記(MyCA, Tbl, i, StR) が2回出てましたよね。 そのタイプに戻してもらうのが簡単だと思います。
(HANA)
>でも、変更が有った場合は上書きするんですよね？ うまく説明できずに申し訳ありません。 CSVには落とさず、変更も修正も転記後のシート↓こちらで直接直す予定です。
4枚目/1部100（1部が部署名、100が部署のコードです）
5枚目/1部100計画（本日要望のあった追加のシートです）
6枚目/2部200
7枚目/2部200計画（本日要望のあった追加のシートです）
8枚目/その他300-500
まずいでしょうか？
全体の工程表というのは↓のブックのことです。
本当にきちんと説明が出来ずに申し訳ありません。
シート名
1枚目/非稼働日
2枚目/受注データ
3枚目/転記 ボタンの名前は「工程表に転記」→Sub Schedule4()です。
4枚目/1部100（1部が部署名、100が部署のコードです）
5枚目/1部100計画（本日要望のあった追加のシートです）
6枚目/2部200
7枚目/2部200計画（本日要望のあった追加のシートです）
8枚目/その他300-500
新規データか？転記済みか？ これについてはもう一度よく考えてみます。
こちらで調べて以下のコードを見つけました。 "3"を"1"に変えて 新しいファイルで実験したところうまくいったのですが、 転記シートで動かすとエラーになってしまいました。
Sub auto_open()
Dim i As Long
With Sheets("sheet1")
For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Now >= DateAdd("m", 3, .Cells(i, 1)) Then
Rows(i).Delete
End If
Next i
.Range("a2").Resize(.Cells(Rows.Count, 1).End(xlUp).Row - 1, .Cells. _
Find("*", , , , xlByColumns, xlPrevious).Column) _
.sort Key1:=Range("A2"), Order1:=xlAscending
End With
End Sub
とりあえず今日はここまででまた明日挑戦してみます。 ありがとうございました。 （苦戦４日目）
自分がエクセルで作業をするならどうするか… 〇のついたデータを転記→〇を「転記済」に置換しておく。 そうすればこの〇は新規の〇か転記がすんでいる〇かを考えなくてすむかな…と考えました。 明日やってみてご報告します。 （苦戦４日目）
＞変更も修正も転記後のシート↓こちらで直接直す予定です。 同じデータは三か所に有る事に成ります。 転記シート（一覧表） 各部署のシート（直接直す予定として、あげておられるシート） 詳細工程表のブック
変更が有った時に、これらをすべて変えておかないと それぞれが有る意味が無いですよね？ とりあえずあるけど、正確な情報かどうかは調べてみないと分からない。 って成っちゃいます。 「最終的には、各部署のシートを見て確認してね」となると、最初からそれを見ますよね。
人が三か所変更しようと思うと大変ですが、エクセルにやらせるのですから 指示さえ出せば、文句も言わずにやってくれると思いますよ。
・・・ただ、この修正を考えるのが面倒なので 一番最初の Schedule のコードを提案したんですけどね。
過去のデータをのけておいて良いなら 数式で参照しておけば、元のデータ（転記シートのデータ）を変更したら その他の二つのシートとブックのデータは勝手に変更されますので。
＞〇のついたデータを転記→〇を「転記済」に置換しておく。 これ、良いアイデアだと思います。 そしたら「○」の時だけ処理すれば良いですからね。
私が作るなら 大きな流れとしては
If セルの値が○だったら Then
If 工事番号が転記済みだったら Then
If 上書きしますかの確認 =VbYes Then
該当の詳細工程表のブックを開く
詳細工程表のブックに転記・・・・・☆
詳細工程表のブックを上書き保存して閉じる
各部署のシートに転記(上書)・・・・★
End If
Else
If 新規登録しますかの確認 = VbYes Then
原本ブックを開く
詳細工程表のブックに転記・・・・・☆
詳細工程表のブックに名前をつけて保存して閉じる
各部署のシートに転記(追加)・・・・★
End If
End If
End If
を行数分繰り返します。
★の所は Sub 転記(ByVal MyCA As Variant, ByVal Tbl As Variant, ByVal MyR As Long, ByVal StR As Long) のコードの事です。
☆の所は、ほとんど同じなので これを改造して ☆・★ 両方に使えるコードにしても良いと思いますし 新たに作っても良いと思います。
＞こちらで調べて以下のコードを見つけました。 のコードは ＞B列の受注日付から30日経過したデータを削除したい。 のコードですか？
でしたら、((受注データ取込_Click))では、オートフィルタを使って不要データを削除しているので それと同じ仕組みを使えば良いと思いますが。。。？
(HANA)
＞ 人が三か所変更しようと思うと大変ですが、エクセルにやらせるのですから ＞ 指示さえ出せば、文句も言わずにやってくれると思いますよ。
いくら稀な事とはいえその通りです…。 自分ではもうどうやったらいいか分からず、 もういいかという気持ちになっておりました。
〇を転記済にしたり原本を開いたりと進んではいますが、 原本への転記→名前を付けて保存のところで、 かなり苦戦しています。 HANAさんが提案してくださったものを参考に、 考え直してみたいと思います。 （苦戦４日目）
＞原本を開いたりと進んではいますが 開くのは、どうやって開いてますか？
MyPath = "C:\test" MyBkn = "原本.xls" Workbooks.Open Filename:=MyPath & "\" & MyBkN
としていたら、
＞原本への転記
'------
Sub 転記2(ByVal MyCA As Variant, ByVal tbl As Variant, ByVal MyR As Long, ByVal MyBkn As String)
Dim i As Long
For i = 0 To UBound(MyCA, 1)
If MyCA(i) <> "" Then
Workbooks(MyBkn).Sheets(1).Range("A1").Range(MyCA(i)).Value = tbl(MyR, i + 1)
End If
Next
End Sub
'------
こんなのを追加して
Call 転記2(MyC2A, tbl, i, MyBkn)
~~~~~原本の方のセルを指定する変数は追加して下さい。
＞名前を付けて保存
は、保存場所がわからないので例として ActiveWorkbook.SaveAs Filename:=MyPath & "\" & tbl(i, 16)
って感じですかね。
直近で似たような事をやったのでとりあえずご紹介を。 [[20130618141103]] 『自動的にリンクさせたい』（sakura）
名前を付けて保存したり、上書き保存したり ハイパーリンクを設定したり
してます。
(HANA)
全て１から作り直していてお返事が遅れてしまい申し訳ありません。 原本のブックを開く方法がHANAさんが教えてくださっていたものと違いました。 Workbooks.Open "C:\Users\工程表H25 test2\02_工番_原本.xlsm"
自信がないのでHANAさんの方に書き換えて、今から転記にかかるところです。
MsgBox "処理が終了しました。" ↑の下に以下のコードを追加して〇を転記済に置換しています。
For i = 2 To 100000
If Cells(i, 1) = "○" Then
Cells(i, 1) = Replace(Cells(i, 1), "○", "転記済")
End If
Next i
MyPath = "C:\Users\Desktop\工程表20130706" MyBkn = "02_工番_原本" Workbooks.Open Filename:=MyPath & "\" & MyBkn
Call 転記2(MyC2A, tbl, i, MyBkn)
~~~~~原本の方のセルを指定する変数は追加して下さい。
原本の方のセルを指定する変数は追加してください。について教えていただきたいのですが、 最初に教えてくださった受注データからの転記の時の以下のコードのようなことでしょうか？ お恥ずかしいのですが、何をどうやったらいいのかご教示願えないでしょうか？ よろしくお願いいたします。
MyCA = Array("", "I7", "A9", "A7", "", "D7", "", "A10", "A11", "D10", "A8", "D8", "D9", "", "", "", "J7")
'A B C D E F G H I J K L M N O P Q
（苦戦４日目）
＞原本のブックを開く方法がHANAさんが教えてくださっていたものと違いました。 ＞Workbooks.Open "C:\Users\工程表H25 test2\02_工番_原本.xlsm" どちらでも大丈夫です。
＞最初に教えてくださった受注データからの転記の時の以下のコードのようなことでしょうか？ です。 転記先のセル番地は違うんですよね？ B列は I7セルではなく どこのセル？ たしか「各部署のシート と 詳細工程表のブック で、転記先のセル番地は違うんだ！！」 ってのはご説明があったと思いますが 「では、具体的にどこ？」ってのは無かったと思います。
その他、「詳細工程表のブックは、工事番号の名前で保存する」 ってご説明は有りましたが「どのフォルダに？」ってのは無いですよね。
今回「原本ブックを開いて 詳細工程表のブックにする」ってのの 「じゃあ、原本ブックってどこにあるの？」は ＞Workbooks.Open "C:\Users\工程表H25 test2\02_工番_原本.xlsm" で、わかりましたが。
ただフォルダ名が「H25」ってのがついているので 別の書き方をした方がよさそうですね。
例えば「マクロがあるのと同じフォルダにあるよ」とか。
コードを書くにあたって、何が不足なのかは 今書いておられる所なのでわかると思います。 たぶん、苦戦４日目さんが作っておられるコードは使えると思いますので それと合わせて 情報の不足を追加して教えて下さい。
なお、このスレは結構長くなってしまいましたので 新しく投稿してもらえたらと思います。
その際、お互いの投稿にリンクをはってください。 [[2013･･･････]]? 『フラグのついたデータを別シートに転記したい（２）』（苦戦４日目） ってな感じで。
(HANA)
『フラグのついたデータを別シートに転記したい（２）』 ↓新しく立て直しました。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.