Excel VBA質問箱 IV

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

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


3868 / 13645 ツリー ←次へ | 前へ→

【59769】条件下でのコピー ガネーシャ 09/1/7(水) 17:57 質問[未読]
【59771】Re:条件下でのコピー りん 09/1/7(水) 18:54 回答[未読]
【59781】Re:条件下でのコピー ガネーシャ 09/1/8(木) 11:13 お礼[未読]

【59769】条件下でのコピー
質問  ガネーシャ  - 09/1/7(水) 17:57 -

引用なし
パスワード
   マスタのシート(wsa)があり、
それは完全に罫線のみでセルは空白です。
wsaの任意の列(B5、B6、、)に、
別のシート(wss)の任意の列の内容(C5、C6、、)を貼り付けたいです。

それを貼り付ける際条件がありまして、
wssのL列に"DC"と入っている場合のみ、
その行のC列目をwsaに貼り付けたいのです。

(wss)
 A  B  C  D  E・・・L
1     米        DC
2     米
3     麦5        DC
4     米        DC
5     麦5
 ↓
 ↓
(wsa)
 A  B  C  D  E
1   米
2   麦5
3   米
4
5
という様に、上から順に羅列されるようにしたいです。

−−
Select Case (月コンボ)
Case "4月"

 Dim wsa As Worksheet
 Dim wss As Worksheet
 Dim i As Long
 Dim D As String
 Dim App As Range
 Dim Ans As Single
 Dim Rmax As Long
 
 Set wsa = ThisWorkbook.Worksheets("マスタ")
 Set wss = ThisWorkbook.Worksheets("4月")

 Rmax = wss.Range("L65536").End(xlUp).Row '集計シート最下行*キーになるL列で判定
 D = "DC"
 i = 5 '開始行

 With wss
  For i = 5 To Rmax
    For Each App In .Range("L5:L" & Rmax) 'wssのL5〜L最終行まで"
     If App.Value = B Then  'L* が B031 だったとき
      Ans = Ans + CLng(.Range("C" & App.Row).Value)
     End If
    Next
    wsa.Range("B" & i).Value = Ans
  Next i
 End With
−−

上記で組んでみたのですが、
思い通りには動きませんでした。

【59771】Re:条件下でのコピー
回答  りん  - 09/1/7(水) 18:54 -

引用なし
パスワード
   ガネーシャ さん、こんばんわ。

>マスタのシート(wsa)があり、
>それは完全に罫線のみでセルは空白です。
>wsaの任意の列(B5、B6、、)に、
>別のシート(wss)の任意の列の内容(C5、C6、、)を貼り付けたいです。
>
>それを貼り付ける際条件がありまして、
>wssのL列に"DC"と入っている場合のみ、
>その行のC列目をwsaに貼り付けたいのです。

Sub test()
  Dim wsa As Worksheet, wss As Worksheet
  Dim Rmax As Long
  Dim i As Long, r As Long
  Dim D As String
  '
  Set wsa = ThisWorkbook.Worksheets("マスタ")
  Set wss = ThisWorkbook.Worksheets("4月")
 
  Rmax = wss.Range("L65536").End(xlUp).Row '集計シート最下行*キーになるL列で判定
  D = "DC" 'L列の一致を確認
  i = 5 '転記先(マスターの書き出し開始行)
 
  With wss
   For r = 5 To Rmax
     If .Cells(r, "L").Value = D Then
      wsa.Cells(i, "B").Value = .Cells(r, "C").Value
      i = i + 1 'ひとつ下
     End If
   Next r
  End With
  '
  Set wsa = Nothing: Set wss = Nothing
End Sub

こんな感じです。

【59781】Re:条件下でのコピー
お礼  ガネーシャ  - 09/1/8(木) 11:13 -

引用なし
パスワード
   りんさん

わあ!できました!!
ありがとうございます!

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