anim130M回答ポイント 555ptウォッチ 2

Excelのマクロに関する質問です。良い回答は、150～350ポイント差し上げます。

ブック内で、あるシートのデータを新規シートに反映させたい。

※あるシートにデータが入力したら、２つの原書シートをコピーして新規シートを２つ作成
※原書シート名は、「情報原書」と「地域原書」

【入力】シート
3　　番号　　　店舗　　科目　　出金　　　損害金
4　　55-110　　岩手　　タコ　　1000　　　300
5　　　　　　　　　　　　　イカ　　400　　　 200
6　　　　　　　　　　　　　カイ　　800　　　 600
7　　55-120　　静岡　　イカ　　300　　　 100
8　　　　　　　　　　　　　タコ　　800　　　 600 ←番号:55-120を入力したら、
　　　　　　　　　　　　　　　　　　　　　　　 下のようなシート作成

□□□入力後イメージ□□□
【120情報】シート
2　A　　　B　　　C　　　D
3　　　　 静岡　　　　　55-120
4　イカ　 タコ
5　300　　800
6　800　　600　　

【120静岡】シート
2　A　　　B　　　C　　　D
3　　　　 静岡　　　　　55-120
4　　　　 イカ　 300　　800
5　　　　 タコ　 800　　600

マクロでの回答は、ソースも記述願います。
どうか宜しくお願いします。

• はてなアカウントでログイン
• 無料ユーザー登録

ベストアンサー

• きゃづみぃ2011/03/08 10:09:40

  満足555pt

  Private Sub Worksheet_Change(ByVal Target As Range)
  '前提条件
  '1列目→2列目→3列目と入力することが前提です。
  
  
  '3列目(仕入先)まで入力があったときに 新規シート作成
  If Target.Column = 3 Then
      a = ActiveSheet.Name
      b1 = Split(Cells(Target.Row, 1), "-")(1) + "情報"
      b2 = Split(Cells(Target.Row, 1), "-")(1) + Cells(Target.Row, 3)
      
      If Not ExistSheet(b1) Then Exit Sub
      If Not ExistSheet(b2) Then Exit Sub
      
      Sheets("情報原書").Copy After:=Sheets(Sheets.Count)
      ActiveSheet.Name = b1
      
      Sheets("地域原書").Copy After:=Sheets(Sheets.Count)
      ActiveSheet.Name = b2
      
      '情報
      Sheets(b1).Range("N1") = Cells(Target.Row, 1)       '発注日
      Sheets(b1).Range("N1") = Cells(Target.Row, 2)       '発注No.
  
      '仕入
      Sheets(b2).Range("L1") = Cells(Target.Row, 2)       '発注No.
      Sheets(b2).Range("K2") = Cells(Target.Row, 1)       '発注日
      
      Sheets(a).Select
      
  End If
  
  '5-9列目の転記
  If Target.Column >= 5 And Target.Column <= 9 Then
      a1 = Target.Row
      If Cells(Target.Row, 3) = "" Then
          a2 = Cells(Target.Row, 3).End(xlUp).Row
      Else
          a2 = a1
      End If
      
      b1 = Split(Cells(a2, 1), "-")(1) + "情報"
      b2 = Split(Cells(a2, 1), "-")(1) + Cells(a2, 3)
      
      If ExistSheet(b1) Then Exit Sub
      If ExistSheet(b2) Then Exit Sub
      
      '情報のセットする場所を求める
      c = 6
      Select Case Target.Column
          Case 5
              c = 10
          Case 6
              c = 6
          Case 7
              c = 7
          Case 8
              c = 8
          Case 9
              c = 11
      End Select
      
      Sheets(b1).Cells(c, a1 - a2 + 3) = Target.Value
      
      
      '情報のセットする場所を求める
      c = 6
      Select Case Target.Column
          Case 5
              c = 4
          Case 6
              c = 6
          Case 7
              c = 7
          Case 8
              c = 8
          Case 9
              c = 9
      End Select
      
      Sheets(b2).Cells(a1 - a2 + 14, c) = Target.Value
  End If
  
  End Sub
  
  
  Function ExistSheet(SheetName) As Boolean
      '引数 SheetName のシートが実際にあるかチェックする
      
      Dim i, cnt As Integer
      
      cnt = Sheets.Count
      ExistSheet = True
      For i = 1 To cnt
          If Sheets(i).Name = SheetName Then
              ExistSheet = False
              Exit For
          End If
      Next
  End Function
  
  
  

  Select Case Target.Columnで 何列目を どこにセットするのか指定しています。

  ここを変えるとセット先を変更できます。

  スター

  • anim130M 2011/03/09 12:25:37

    大変ありがとうございました。

    思い通りに動いております。

その他の回答

• きゃづみぃ2011/03/06 07:54:04

  0pt

  静岡のイカの損害金は100となってますが、これが転記されると800?になってます。

  これについて記述がなかったので 誤りと判断し、そのままの値を転記しています。

  なお以下のソースは、入力するシートのところに貼り付けてください。

  
  
  

  Private Sub Worksheet_Change(ByVal Target As Range)
  '前提条件
  '1列目→2列目→3列目と入力することが前提です。
  
  
  '2列目に入力があったときは 新規シート作成
  If Target.Column = 2 Then
      a = ActiveSheet.Name
      b1 = Split(Cells(Target.Row, 1), "-")(1) + "情報"
      b2 = Split(Cells(Target.Row, 1), "-")(1) + Cells(Target.Row, 2)
      
      If Not ExistSheet(b1) Then Exit Sub
      If Not ExistSheet(b2) Then Exit Sub
      
      Sheets("情報原書").Copy After:=Sheets(Sheets.Count)
      ActiveSheet.Name = b1
      
      Sheets("情報原書").Copy After:=Sheets(Sheets.Count)
      ActiveSheet.Name = b2
      
      Sheets(b1).Range("B3") = Cells(Target.Row, 2)
      Sheets(b1).Range("D3") = Cells(Target.Row, 1)
  
      Sheets(b2).Range("B3") = Cells(Target.Row, 2)
      Sheets(b2).Range("D3") = Cells(Target.Row, 1)
      
      Sheets(a).Select
      
  End If
  
  '3-5列目の転記
  If Target.Column >= 3 And Target.Column <= 5 Then
      a1 = Target.Row
      If Cells(Target.Row, 2) = "" Then
          a2 = Cells(Target.Row, 2).End(xlUp).Row
      Else
          a2 = a1
      End If
      
      b1 = Split(Cells(a2, 1), "-")(1) + "情報"
      b2 = Split(Cells(a2, 1), "-")(1) + Cells(a2, 2)
      
      If ExistSheet(b1) Then Exit Sub
      If ExistSheet(b2) Then Exit Sub
      Sheets(b1).Cells(Target.Column + 1, a1 - a2 + 1) = Target.Value
      Sheets(b2).Cells(a1 - a2 + 4, Target.Column - 1) = Target.Value
  End If
  
  End Sub
  
  
  Function ExistSheet(SheetName) As Boolean
      '引数 SheetName のシートが実際にあるかチェックする
      
      Dim i, cnt As Integer
      
      cnt = Sheets.Count
      ExistSheet = True
      For i = 1 To cnt
          If Sheets(i).Name = SheetName Then
              ExistSheet = False
              Exit For
          End If
      Next
  End Function
  
  
  

  スター

  • anim130M 2011/03/06 23:33:26

    '3-5列目の転記 を実行しますと、

    ActiveSheet（【入力】シート）に値を返してしまいました、

    どの部分の記載を修正すればよろしいでしょうか？

toki-21312011/03/06 11:45:16

0pt

Private Sub Worksheet_Change(ByVal Target As Range)

'前提条件

'1列目→2列目→3列目と入力することが前提です。




'2列目に入力があったときは 新規シート作成

If Target.Column = 2 Then

a = ActiveSheet.Name

b1 = Split(Cells(Target.Row, 1), "-")(1) + "情報"

b2 = Split(Cells(Target.Row, 1), "-")(1) + Cells(Target.Row, 2)

If Not ExistSheet(b1) Then Exit Sub

If Not ExistSheet(b2) Then Exit Sub

Sheets("情報原書").Copy After:=Sheets(Sheets.Count)

ActiveSheet.Name = b1

Sheets("情報原書").Copy After:=Sheets(Sheets.Count)

ActiveSheet.Name = b2

Sheets(b1).Range("B3") = Cells(Target.Row, 2)

Sheets(b1).Range("D3") = Cells(Target.Row, 1)

Sheets(b2).Range("B3") = Cells(Target.Row, 2)

Sheets(b2).Range("D3") = Cells(Target.Row, 1)

Sheets(a).Select

End If

'3-5列目の転記

If Target.Column >= 3 And Target.Column <= 5 Then

a1 = Target.Row

If Cells(Target.Row, 2) = "" Then

a2 = Cells(Target.Row, 2).End(xlUp).Row

Else

a2 = a1

End If

b1 = Split(Cells(a2, 1), "-")(1) + "情報"

b2 = Split(Cells(a2, 1), "-")(1) + Cells(a2, 2)

If ExistSheet(b1) Then Exit Sub

If ExistSheet(b2) Then Exit Sub

Sheets(b1).Cells(Target.Column + 1, a1 - a2 + 1) = Target.Value

Sheets(b2).Cells(a1 - a2 + 4, Target.Column - 1) = Target.Value

End If

End Sub




Function ExistSheet(SheetName) As Boolean

'引数 SheetName のシートが実際にあるかチェックする

Dim i, cnt As Integer

cnt = Sheets.Count

ExistSheet = True

For i = 1 To cnt

If Sheets(i).Name = SheetName Then

ExistSheet = False

Exit For

End If

Next

End Function

これでどうでしょうか

スター

• anim130M 2011/03/07 15:38:36

  回答ありがとうございます。

  ＞Sheets(b1).Cells(Target.Column + 1, a1 - a2 + 1) = Target.Value

  ＞Sheets(b2).Cells(a1 - a2 + 4, Target.Column - 1) = Target.Value

  
  

  【120情報】シート

  　C6：C10～G6：G10の範囲内で列単位で反映させたい

  【120静岡】シート

  　D14：D25～D14：D25の範囲内で行単位で反映させたい

  上記の条件の場合、どのようにマクロを修正したらよろしいでしょうか？

• その他の回答を読む

この質問へのコメント

• きゃづみぃ2011/03/07 07:01:56
  ＞'3-5列目の転記 を実行しますと、
  ＞ActiveSheet（【入力】シート）に値を返してしまいました、
  ＞どの部分の記載を修正すればよろしいでしょうか？
  
  
  3-5列目では どこのシートに転記するかということで
  入力した行から 番号と店舗を取得し、そのシートに転記しています。
  
  そのシートがなければ、転記しません。
  ActiveSheet（【入力】シート）に入力したままです。
  
  ActiveSheet（【入力】シート）のシート名が 【120情報】とかいう名前だったら 考えられますが・・・。
  
  
• anim130M2011/03/07 15:39:03
  回答ありがとうございます。
  ＞Sheets(b1).Cells(Target.Column + 1,a1 - a2 + 1) = Target.Value
  ＞Sheets(b2).Cells(a1 - a2 + 4,Target.Column - 1) = Target.Value
  
  【120情報】シート
  　C6：C10～G6：G10の範囲内で列単位で反映させたい
  【120静岡】シート
  　D14：D25～D14：D25の範囲内で行単位で反映させたい
  上記の条件の場合、どのようにマクロを修正したらよろしいでしょうか？
• きゃづみぃ2011/03/07 16:11:48
  イメージが まったくつかめませんので、はてなフォトライフにでも エクセルの画面をキャプチャしたのを貼り付けてくれたらいいかと思います。
  
  http://f.hatena.ne.jp/
  
  ＞C6：C10～G6：G10の範囲内
  
  C6：C10が ひとつの範囲です。
  これらは 【120情報】シートの範囲ですか？
  
  【入力】シートの範囲は どうなりますか？
  具体的に 【入力】シートのC6が 【120情報】シートのC6になるといったような説明があると 間違いが減ります。
  
  
  ＞D14：D25～D14：D25の範囲内
  D14：D25が 最初と後で出てきます。
  
• anim130M2011/03/07 17:48:33
  いつもいつもありがとうございます。
  上手く説明ができなく申し訳ございませんでした。
  
  http://f.hatena.ne.jp/anim130M/
  ↑に画像を貼りました。
  ■ f:id:anim130M:20110307173340g:image：【120静岡】シート
  ■ f:id:anim130M:20110307173339g:image：【120情報】シート
  ■ f:id:anim130M:20110307173338j:image：【入力】シート
  
  
  
• きゃづみぃ2011/03/07 22:40:05
  ＞番号:55-120を入力したら、下のようなシート作成
  これが ちょっと ひっかかってたんです。
  
  番号は最後に 入力になるんですか？
  
  普通の入力する順番では ちょっと わかりにくいかなと思います。
  
• anim130M2011/03/08 08:28:25
  ありがとうございます。
  
  番号:55-120は、taknt様から頂いた、vbaマクロの仕様通り、
  最初に入力したいと思っております。
  
  
• きゃづみぃ2011/03/08 14:03:47
  あ、ミスがありました。すみません。
  
  Sheets(b1).Range("N1") = Cells(Target.Row, 2) '発注No.
  
  ↓
  
  Sheets(b1).Range("N2") = Cells(Target.Row, 2) '発注No.
  
  発注日を上書きしちゃった。
  
• SALINGER2011/03/08 14:41:11
  図を拝見するに仕様についての話なのですが、入力の任意のタイミングでシートを作成するというのは
  あまりスマートな方法じゃないです。
  入力シートの図だと300行とかになってるので、入力データが多いことが想像できますので、
  シートが100枚以上とかすぐに肥大化するように思います。
  本来なら入力シート、発注書、納入先のシートで3枚だけにして、発注NOでカード型にするのがベターでしょう。
  図を拝見すると発注書や納品先は印刷目的だと思うので、発注Noのところをドロップダウンにするか、
  数値を入力すると対象の発注書に切り替わる形にすれば、ほとんどワークシート関数でできることです。
  まあ、別の方法もあるよということで提言させてもらいます。
  

質問の情報

登録日時

2011-03-06 01:39:01

終了日時

2011-03-09 12:27:08

回答条件

1人20回まで

この質問のカテゴリ

• ビジネス・経営
• コンピュータ

この質問に含まれるキーワード

人気の質問

• 36歳です。卵巣腫瘍疑いで大学病院に10月1日に受診しました。エコーで充実性腫瘍があるから至急MRIと腫瘍マ…ikkuchaan11日前
• 同じような体験をしたことがある人はいますか？。 ある日、お葬式の職業に就きたいなあなんて話題にしてい…匿名質問者14日前
• 私は、【チルスポ】　という名前で、 チルスポット情報を共有するアプリを開発しています。 皆さんの知って…匿名質問者12日前
• b型就労支援施設に通っている方に質問です。どういうことが通っていて辛いと感じますか？他の利用者の方と…匿名質問者2日前
• 今行きがかり上で中小企業を相手に民事訴訟の原告と被告で2件の裁判を抱えています。しかし何も深刻さはな…asnaro_71122時間前

メニュー

• 質問一覧
• カテゴリ一覧
• 無料ユーザー登録
• 人力検索はてなトップ

PC版

• お問い合わせ
• ヘルプ
• お知らせ
• はてなトップ