人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excelのマクロに関する質問です。良い回答は、150?350ポイント差し上げます。
ブック内で、あるシートのデータを新規シートに反映させたい。

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

【入力】シート
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

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

●質問者: anim130M
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:Excel □□□ イメージ コピー ソース
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● きゃづみぃ
●0ポイント

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


◎質問者からの返答

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

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

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


2 ● toki-2131
●0ポイント

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

これでどうでしょうか

◎質問者からの返答

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

>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の範囲内で行単位で反映させたい

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


3 ● きゃづみぃ
●555ポイント ベストアンサー
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で 何列目を どこにセットするのか指定しています。

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

◎質問者からの返答

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ