[go: up one dir, main page]
More Web Proxy on the site http://driver.im/
id:anim130M
ポイントあり555ptベストアンサーあり
ビジネス・経営コンピュータ

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

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

回答の条件
  • 1人20回まで
  • 登録：
  • 終了：2011/03/09 12:27:08
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:taknt No.3

回答回数13539ベストアンサー獲得回数1198

ポイント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で 何列目を どこにセットするのか指定しています。

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

id:anim130M

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

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

2011/03/09 12:25:37

その他の回答（2件）

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

静岡のイカの損害金は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
id:anim130M

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

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

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

2011/03/06 23:33:26
id:toki-2131 No.2

回答回数138ベストアンサー獲得回数1

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

これでどうでしょうか

id:anim130M

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

＞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 15:38:36
id:taknt No.3

回答回数13539ベストアンサー獲得回数1198ここでベストアンサー

ポイント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で 何列目を どこにセットするのか指定しています。

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

id:anim130M

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

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

2011/03/09 12:25:37

コメント（8件)

  • id:taknt
    きゃづみぃ 2011/03/07 07:01:56
    ＞'3-5列目の転記 を実行しますと、
    ＞ActiveSheet（【入力】シート）に値を返してしまいました、
    ＞どの部分の記載を修正すればよろしいでしょうか？


    3-5列目では どこのシートに転記するかということで
    入力した行から 番号と店舗を取得し、そのシートに転記しています。

    そのシートがなければ、転記しません。
    ActiveSheet（【入力】シート）に入力したままです。

    ActiveSheet（【入力】シート）のシート名が 【120情報】とかいう名前だったら 考えられますが・・・。

  • id:anim130M
    anim130M 2011/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の範囲内で行単位で反映させたい
    上記の条件の場合、どのようにマクロを修正したらよろしいでしょうか？
  • id:taknt
    きゃづみぃ 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が 最初と後で出てきます。
  • id:anim130M
    anim130M 2011/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：【入力】シート


  • id:taknt
    きゃづみぃ 2011/03/07 22:40:05
    ＞番号:55-120を入力したら、下のようなシート作成
    これが ちょっと ひっかかってたんです。

    番号は最後に 入力になるんですか？

    普通の入力する順番では ちょっと わかりにくいかなと思います。
  • id:anim130M
    anim130M 2011/03/08 08:28:25
    ありがとうございます。

    番号:55-120は、taknt様から頂いた、vbaマクロの仕様通り、
    最初に入力したいと思っております。

  • id:taknt
    きゃづみぃ 2011/03/08 14:03:47
    あ、ミスがありました。すみません。

    Sheets(b1).Range("N1") = Cells(Target.Row, 2) '発注No.

    ↓

    Sheets(b1).Range("N2") = Cells(Target.Row, 2) '発注No.

    発注日を上書きしちゃった。
  • id:SALINGER
    SALINGER 2011/03/08 14:41:11
    図を拝見するに仕様についての話なのですが、入力の任意のタイミングでシートを作成するというのは
    あまりスマートな方法じゃないです。
    入力シートの図だと300行とかになってるので、入力データが多いことが想像できますので、
    シートが100枚以上とかすぐに肥大化するように思います。
    本来なら入力シート、発注書、納入先のシートで3枚だけにして、発注NOでカード型にするのがベターでしょう。
    図を拝見すると発注書や納品先は印刷目的だと思うので、発注Noのところをドロップダウンにするか、
    数値を入力すると対象の発注書に切り替わる形にすれば、ほとんどワークシート関数でできることです。
    まあ、別の方法もあるよということで提言させてもらいます。

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ