Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1041 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【76641】複数のシートの転記について ももかん 15/2/22(日) 14:28 質問[未読]
【76642】Re:複数のシートの転記について マナ 15/2/22(日) 16:02 発言[未読]
【76644】Re:複数のシートの転記について マナ 15/2/22(日) 16:49 発言[未読]
【76651】Re:複数のシートの転記について マナ 15/2/23(月) 22:31 発言[未読]
【76646】Re:複数のシートの転記について β 15/2/22(日) 17:25 発言[未読]
【76657】Re:複数のシートの転記について ももかん 15/2/24(火) 12:09 お礼[未読]
【76641】複数のシートの転記について
質問  ももかん E-MAIL  - 15/2/22(日) 14:28 -
引用なし
パスワード
   初めて質問させてもらいます。よろしくお願いします。

1つのエクセルブックの中に複数のシートがあります。
顧客情報の入力されているシートに別シートの単価を転記する方法を探しています。


★201502★→2月分の顧客情報シート
　　Ａ列　Ｂ列　Ｃ列　Ｄ列　　Ｅ列　　Ｆ列
１
２　
３　番号　氏名　ＩＤ　単価１　単価２　単価３
４　 1　　田中　 66
５　 2　　佐藤　 99
６　 3　　鈴木　　9
７　 4　　斉藤　 12
８　 5　　相田　 17
９
10　 6　　遠藤　　7
　　↓
　データ数は毎月変動して、必ず途中に空白行が入ります。
　シート名も毎月異なり、2月分のシート名は201502、1月分は201501…という風にかわります。

★201502単価★→2月分の単価シート
　　Ａ列　Ｂ列　Ｃ列　　Ｄ列　　Ｅ列
１　氏名　ＩＤ　単価１　単価２　単価３
２　田中　 66　 500　　 1020　　510
３　佐藤　 99　　50　　　160　　500
４　鈴木　　9　 110　　　650　　240
５　斉藤　 12　 780　　 1200　　 50
６　相田　 17　 300　　　450　　120
７　遠藤　　7　 220　　　 80　　260


顧客情報の入力されているシート名は月毎に異なり、2月分のシート名は201502、1月分は201501…となっています。
単価の入力されているシート名も月毎に異なり、2月分の単価シートは201502単価、1月分の単価シートは201501単価…となっています。
2月分の単価シートの単価1、単価2、単価3を2月分の顧客情報のシートの単価1、単価2、単価3に転記させて、ブックの中にあるすべての単価シートを対応する月の顧客情報のシートの転記したいです。

ソフトから顧客情報をエクセルファイルに落とすので、顧客情報のシート数はその都度変動、データ行も月毎に変動します。
単価シートも顧客情報のシート数の連動しているのでその都度変動、データ行も月毎に変動します。

どうぞよろしくお願いします。
【76642】Re:複数のシートの転記について
発言  マナ  - 15/2/22(日) 16:02 -
引用なし
パスワード
   修正し再投稿

Sub test()
　　Dim dic As Object
　　Dim s As String
　　Dim ws As Worksheet
　　Dim r As Long
　　Dim v
　　Dim i As Long
　　Dim c As Range
　　Dim idx As Long
　　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　For Each ws In Worksheets
　　
　　　　If ws.Name Like "*単価" Then
　　　　　　
　　　　　　v = ws.Range("A1").CurrentRegion.Value
　　　　　　
　　　　　　For i = 2 To UBound(v)
　　　　　　　　dic(v(i, 2)) = Array(v(i, 3), v(i, 4), v(i, 5))
　　　　　　Next
　　　　　　
　　　　　　s = Left(ws.Name, 6)
　　　　　　r = Worksheets(s).Range("C" & Rows.Count).End(xlUp).Row
　　　　　　
　　　　　　For Each c In Worksheets(s).Range("C4:C" & r)
　　　　　　　　If dic.exists(c.Value) Then
　　　　　　　　　　c.Offset(, 1).Resize(, 3).Value = dic(c.Value)
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　Next
　
End Sub
【76644】Re:複数のシートの転記について
発言  マナ  - 15/2/22(日) 16:49 -
引用なし
パスワード
   統合のほうが簡単かも。

Sub test2()
　Dim 統合先 As Range, 統合元 As Range
　　Dim s As String
　　Dim ws As Worksheet
　　Dim r As Long
　　
　　For Each ws In Worksheets
　　
　　　　If ws.Name Like "*単価" Then
　　　　　　
　　　　　　Set 統合元 = ws.Range("A1").CurrentRegion.Offset(, 1).Resize(, 4)
　　　　
　　　　　　s = Left(ws.Name, 6)
　　　　　　With Worksheets(s)
　　　　　　　　r = .Range("C" & .Rows.Count).End(xlUp).Row
　　　　　　　　Set 統合先 = .Range("C3:C" & r)
　　　　　　End With

　　　　　　統合先.Consolidate _
　　　　　　　　Sources:=統合元.Address(ReferenceStyle:=xlR1C1, External:=True), _
　　　　　　　　Function:=xlSum, _
　　　　　　　　TopRow:=True, _
　　　　　　　　LeftColumn:=True
　　　　　　
　　　　End If
　　Next
　　
End Sub
【76646】Re:複数のシートの転記について
発言  β  - 15/2/22(日) 17:25 -
引用なし
パスワード
   ▼ももかん さん：

すでにマナさんから模範解答がでていますので変化球です。

Sub Test()
　　Dim mSh As Worksheet
　　Dim pSh As Worksheet
　　Dim mList As Range
　　Dim pList As Range
　　
　　For Each mSh In Worksheets
　　　　If Not mSh.Name Like "*単価" Then　 '月シート
　　　　　　Set pSh = Nothing
　　　　　　On Error Resume Next
　　　　　　Set pSh = Sheets(mSh.Name & "単価")
　　　　　　On Error GoTo 0
　　　　　　If Not pSh Is Nothing Then　　　　　'単価シートあり
　　　　　　　　Set mList = mSh.Range("C4", mSh.Range("C" & Rows.Count).End(xlUp)).Offset(, 1).Resize(, 3)
　　　　　　　　With pSh.Range("A1").CurrentRegion
　　　　　　　　　　Set pList = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
　　　　　　　　End With
　　　　　　　　mList.Formula = "=IF($C4="""","""",VLOOKUP($C4,'" & pSh.Name & "'!" & pList.Address & ",COLUMN(B1),FALSE))"
　　　　　　　　mList.Value = mList.Value
　　　　　　End If
　　　　End If
　　Next
　　　　　　
End Sub
【76651】Re:複数のシートの転記について
発言  マナ  - 15/2/23(月) 22:31 -
引用なし
パスワード
   間違い発見。（今回に限っては結果が同じですが）

>Set 統合先 = .Range("C3:C" & r)
は
Set 統合先 = .Range("C3:F" & r)
にしたつもりでした。

せっかく、
>TopRow:=True, _
なので。
【76657】Re:複数のシートの転記について
お礼  ももかん E-MAIL  - 15/2/24(火) 12:09 -
引用なし
パスワード
   >マナ様
>β様

ご教授ありがとうございました。
こんなに短いコードで出来てしまうとは…脱帽です
自分で考えてたコードは恥ずかしいくらいに長くてぐちゃぐちゃでした…

実装したいファイルは提示したデータよりも
行も列も多いのでこれを自分でアレンジしてみたいと思います。

本当にありがとうございました。
これからも頑張りたいと思います。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1041 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free