Excel VBA質問箱 IV

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

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


1040 / 13644 ツリー ←次へ | 前へ→

【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月分の顧客情報シート
  A列 B列 C列 D列  E列  F列

2 
3 番号 氏名 ID 単価1 単価2 単価3
4  1  田中  66
5  2  佐藤  99
6  3  鈴木  9
7  4  斉藤  12
8  5  相田  17

10  6  遠藤  7
  ↓
 データ数は毎月変動して、必ず途中に空白行が入ります。
 シート名も毎月異なり、2月分のシート名は201502、1月分は201501…という風にかわります。

★201502単価★→2月分の単価シート
  A列 B列 C列  D列  E列
1 氏名 ID 単価1 単価2 単価3
2 田中  66  500   1020  510
3 佐藤  99  50   160  500
4 鈴木  9  110   650  240
5 斉藤  12  780   1200   50
6 相田  17  300   450  120
7 遠藤  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 -

引用なし
パスワード
   >マナ様
>β様

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

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

本当にありがとうございました。
これからも頑張りたいと思います。

1040 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free