Excel VBA質問箱 IV

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

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


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

【40183】VBAデータの挿入の仕方 あおし 06/7/7(金) 23:46 質問[未読]
【40185】Re:VBAデータの挿入の仕方 Ned 06/7/8(土) 0:06 発言[未読]
【40224】Re:VBAデータの挿入の仕方 Ned 06/7/9(日) 18:32 発言[未読]

【40183】VBAデータの挿入の仕方
質問  あおし  - 06/7/7(金) 23:46 -

引用なし
パスワード
   元データ
場所 |      保育所      |
項目ID|   B501   |   B502   |
 年 |2002年|2003年|2002年|2003年|
松戸市| 35 | 54 | 35 | 54 |
船橋市| 21 | 35 | 21 | 35 |
市川市| 15 | 23 | 15 | 23 |

更新用データ
場所 |保育所|
項目ID| B501 |
 年 | 2004 |
松戸市| 25 |
船橋市| 45 |
市川市| 31 |

更新した後の表示
場所 |        保育所        |
項目ID|     B501     |   B502   |
 年 |2002年|2003年|2004年|2002年|2003年|
松戸市| 35 | 54 | 25 | 10 | 50 |
船橋市| 21 | 35 | 45 | 20 | 16 |
市川市| 15 | 23 | 31 | 25 | 23 |

上の表みたいなデータの更新をしたくて
まず項目IDの列をB501で検索かけて見つかったら空白の行を挿入してと
考えていたのですがセルが結合していたりと
全然思ったように動きません。

どのように記述すればよいか教えていただけないでしょうか。
よろしくお願いいたします。

【40185】Re:VBAデータの挿入の仕方
発言  Ned  - 06/7/8(土) 0:06 -

引用なし
パスワード
   こんにちは。余計なお世話かもしれませんが、後々の事を考えると、

場所     ID     年      市      データ
保育所    B501    2002年    松戸市    35
保育所    B501    2002年    船橋市    21
保育所    B501    2002年    市川市    15
保育所    B501    2003年    松戸市    54
保育所    B501    2003年    船橋市    35
保育所    B501    2003年    市川市    23

保育所    B502    2003年    松戸市    54
保育所    B502    2003年    船橋市    35
保育所    B502    2003年    市川市    23

な感じの、データベース形式でデータをつくっておいたほうがいいですよ。
そうすると、ピボットテーブルなどを使って、簡単に集計・分析ができます。

【40224】Re:VBAデータの挿入の仕方
発言  Ned  - 06/7/9(日) 18:32 -

引用なし
パスワード
   シート名 元データ
    A      B      C      D      E  
1    場所     保育所            
2    項目ID    B501            B502    
3    年      2002年    2003年    2002年    2003年
4    松戸市      35      54      35      54
5    船橋市      21      35      21      35
6    市川市      15      23      15      23

結合セル
B1:E1
B2:C2
D2:E2

シート名 更新用データ
    A      B  
1    場所     保育所
2    項目ID    B501 
3    年      2004年
4    松戸市      25
5    船橋市      45
6    市川市      31

上記条件の時、下記コードで試してみました。

Sub sample()
  Dim v, x, xi
  Dim r1 As Range, r2 As Range, r3 As Range
  Dim flg As Boolean
  Dim a As String
  With Sheets("更新用データ")
    v = Application.Transpose(.Range("b1:b3").Value)
    x = .Range("a4", .Range("a65536").End(xlUp)).Value
  End With
  With Sheets("元データ")
    Set r1 = .Rows(1).Find(What:=v(1), LookIn:=xlValues _
      , LookAt:=xlWhole, SearchOrder:=xlByColumns)
    If Not r1 Is Nothing Then
      Set r1 = r1.MergeArea
      Set r2 = r1.EntireColumn.Rows(2).Find(What:=v(2))
      If Not r2 Is Nothing Then
        Set r2 = r2.MergeArea
        Set r3 = r2.EntireColumn.Rows(3).Find(What:=v(3))
        If r3 Is Nothing Then
          Set r3 = r2.Offset(1).Offset(, r2.Columns.Count).Resize(, 1)
          If Intersect(r3, r1.EntireColumn) Is Nothing Then flg = True
          r3.EntireColumn.Insert
          For Each xi In x
            If IsError(Application.Match(xi, .Columns("a"), 0)) Then _
              .Range("a65536").End(xlUp).Offset(1).Value = xi
          Next xi
          With r3.Offset(, -1).Resize(.Range("a65536").End(xlUp).Row - 2)
            .Formula = "=VLOOKUP(A3,更新用データ!A:B,2,0)"
            .Value = .Value
          End With
          r2.Resize(, r2.Columns.Count + 1).Merge
          If flg Then r1.Resize(, r1.Columns.Count + 1).Merge
          Set r3 = Nothing
          a = "更新OK"
        Else
          a = v(3) & " 有"
        End If
        Set r2 = Nothing
      Else
        a = v(2) & " 無"
      End If
      Set r1 = Nothing
    Else
      a = v(1) & " 無"
    End If
  End With
  MsgBox a
End Sub

やはり結合セルがあるとメンドくさいです。
#いや、もっとスマートな方法があるとは思うのですが...

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