| |
▼awu さん：
>VBAを使わなくてもVLookUp関数等を使用した計算式で対応出来そうな
>内容ですが、VBAで処理すると、こんな感じで如何でしょうか。
>
ご回答ありがとうございます。
おかげさまで、以下の様に記して無事に解決いたしました。
変数は、当方の理解しやすい文字に変えてます。
Sub 検索値貼付()
Dim rng1 As Range
Dim rng2 As Range
Dim n As Long
Dim z As Long
z = Range("W138").End(xlDown).Row
For n = 3 To 87 Step 3
Set rng1 = Range("B" & n)
Set rng2 = Range("W138:W" & z).Find(rng1.Value, lookat:=xlWhole)
If Not rng2 Is Nothing Then
rng1.Offset(, 5).Value = rng2.Offset(, 1).Value
End If
Next n
For n = 90 To 93
Set rng1 = Range("B" & n)
Set rng2 = Range("W138:W" & z).Find(rng1.Value, lookat:=xlWhole)
If Not rng2 Is Nothing Then
rng1.Offset(, 5).Value = rng2.Offset(, 1).Value
End If
Next n
Set rng1 = Nothing: Set rng2 = Nothing
End Sub
続けて、質問なのですが、
実は、貼り付け位置（※２）であるG列"G3"〜"G93"の一つ上のセル"G2"に
見出し"01"が元々あるのですが、そのまま、右方向にセル"H2","I2","J2"・・・に
"02","03","04"・・・"30"まで見出しがあるのです。
（この見出しは、元のBOOK名です。（つまりブックが30個あってそこから貼り付けたいのです））
そこでコピーしたいデータ（※１）（いったんそれぞれのブックから貼り付けられた表）セル"W138"から下方向にある領域の見出しとしてセル"W137"にブック名"01"や"02"等が貼り付けられてるとした場合
そのセル"W137"の値を参照して、貼り付け位置（※２）のオフセット位置を取得したいのですが
その場合の方法は、どういう記述がBESTでしょうか？
一応、素人ながら、Select Caseで記述してうまく作動はしたのですが
セレクトケースが３０通りもあり、とても長くなってしまいます。
以下に、記述しますので、もしも、簡潔に綺麗にまとめる記述方法が
ありましたら、教えて頂ければ幸いです。
よろしくお願いいたします。
Sub 検索値貼付()
Dim rng1 As Range
Dim rng2 As Range
Dim n As Long
Dim z As Long
Dim book As String
Dim No As String
book = Range("W137").Value
Select Case book
Case "01"
No = 5
Case "02"
No = 6
Case "03"
No = 7
Case "04"
No = 8
Case "05"
No = 9
Case "06"
No = 10
Case "07"
No = 11
Case "08"
No = 12
Case "09"
No = 13
Case "10"
No = 14
Case "11"
No = 15
Case "12"
No = 16
Case "13"
No = 17
Case "14"
No = 18
Case "15"
No = 19
Case "16"
No = 20
Case "17"
No = 21
Case "18"
No = 22
Case "19"
No = 23
Case "20"
No = 24
Case "21"
No = 25
Case "22"
No = 26
Case "23"
No = 27
Case "24"
No = 28
Case "25"
No = 29
Case "26"
No = 30
Case "27"
No = 31
Case "28"
No = 32
Case "29"
No = 33
Case "30"
No = 34
Case Else
Exit Sub
End Select
z = Range("W138").End(xlDown).Row
For n = 3 To 87 Step 3
Set rng1 = Range("B" & n)
Set rng2 = Range("W138:W" & z).Find(rng1.Value, lookat:=xlWhole)
If Not rng2 Is Nothing Then
rng1.Offset(, No).Value = rng2.Offset(, 1).Value
End If
Next n
For n = 90 To 93
Set rng1 = Range("B" & n)
Set rng2 = Range("W138:W" & z).Find(rng1.Value, lookat:=xlWhole)
If Not rng2 Is Nothing Then
rng1.Offset(, No).Value = rng2.Offset(, 1).Value
End If
Next n
Set rng1 = Nothing: Set rng2 = Nothing
End Sub
わかりにくいかもしれませんが、よろしくお願いいたします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
