Excel VBA質問箱 IV

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

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


4009 / 13646 ツリー ←次へ | 前へ→

【58828】シート1にシート2のデーターの貼付け 伊藤 08/11/13(木) 10:41 質問[未読]
【58829】Re:シート1にシート2のデーターの貼付け にぃ 08/11/13(木) 11:02 発言[未読]
【58831】Re:シート1にシート2のデーターの貼付け にぃ 08/11/13(木) 11:14 発言[未読]
【58880】Re:シート1にシート2のデーターの貼付け 伊藤 08/11/15(土) 20:46 お礼[未読]
【58884】Re:シート1にシート2のデーターの貼付け Hirofumi 08/11/16(日) 11:53 発言[未読]
【58897】Re:シート1にシート2のデーターの貼付け 伊藤 08/11/17(月) 9:17 お礼[未読]

【58828】シート1にシート2のデーターの貼付け
質問  伊藤  - 08/11/13(木) 10:41 -

引用なし
パスワード
   シート1のデーターにシート2のデーターを貼り付ける                            
sheet1(受注台帳)                            
  顧客コード    品名  個数 金額       顧客コード    顧客名    住所
1    1002    LLL    5    5000    1002    いいい    2222
2    1006    BBB    3    3000    1006    たたた    6666
3    1008    CCC    5    6000    1008    つつつ    8888
4    1008    DDD    8    9000            
5    1009    GGG    5    5000    1009    ててて    9999
6    1009    KKK    3    3000            
7    1009    AAA    2    3000            
sheet2(顧客台帳)                            
   顧客コード    顧客名    住所                
1    1001    あああ    1111                
2    1002    いいい    2222                
3    1003    ううう    3333                
4    1004    えええ    4444                
5    1005    おおお    5555                    
6    1006    たたた    6666                    
7    1007    ちちち    7777                    
8    1008    つつつ    8888                    
9    1009    ててて    9999                    
10    1010    とととと                                                        
sheet1とsheet2の顧客コードが一致した場合、sheet1に顧客名、住所を貼付                    
sheet1 受注1行ごとの出荷指示書を作成しょうと思っています。                                    
  count = 0                            
s1max = Sheets("補助1").Range("A" & Sheets("補助1").Rows.count).End(xlUp).Row                                    
s2max = Sheets("補助2").Range("A" & Sheets("補助2").Rows.count).End(xlUp).Row                                    
  For i = 2 To s2max                                    
   For j = 2 To s1max                                    
   If Sheets("補助1").Cells(j, 2) = Sheets("補助2").Cells(i, 2) Then                                
     count = count + 1                                                    Sheets("補助2").Range(Sheets("補助2").Cells(i, 3), Sheets("補助2").Cells(i, 4)).Copy                                    
     Sheets("補助1").Cells(j, 6).PasteSpecial Paste:=xlPasteValues                                     
     Exit For                                    
    End If                                    
    Next j                                    
  Next i                                    
 このマクロで貼り付けられるのですがsheet1の顧客コードが同じの場合                                    
 例 1008が2行、1009が3行には各一行しか貼付けができません                                    
 全ての行に顧客名、住所を貼り付けたいのです。宜しくご指導願えますか。

【58829】Re:シート1にシート2のデーターの貼付け
発言  にぃ  - 08/11/13(木) 11:02 -

引用なし
パスワード
   ▼伊藤 さん:
こんにちは!
             
>全ての行に顧客名、住所を貼り付けたいのです。
これでしたら
>Exit For
を取り除いてあげればいいと思います。
ただ、かなりの量の行数ですと処理時間が長くなってしまいますが。
行数はたくさんありますか?

ちなみに余計なことかもしれませんが、このようにすると
コードがみやすくなるかもしれません。
こちらは参考までに。

Dim ws1 As Worksheet
Dim ws2 As Worksheet

ws1 = Sheets("補助1")
ws2 = Sheets("補助2")

  count = 0
s1max = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
s2max = ws2.Range("A" & ws2.Rows.count).End(xlUp).Row
  For i = 2 To s2max
   For j = 2 To s1max
   If ws1.Cells(j, 2).Value = ws2.Cells(i, 2).Value Then
     count = count + 1
    ws2.Range(ws2.Cells(i, 3), ws2.Cells(i, 4)).Copy
     ws1.Cells(j, 6).PasteSpecial Paste:=xlPasteValues
     'Exit For コメントにしてあります
    End If
    Next j
  Next i

【58831】Re:シート1にシート2のデーターの貼付け
発言  にぃ  - 08/11/13(木) 11:14 -

引用なし
パスワード
   >ws1 = Sheets("補助1")
>ws2 = Sheets("補助2")
↑すみません訂正です。

Set ws1 = Sheets("補助1")
Set ws2 = Sheets("補助2")

【58880】Re:シート1にシート2のデーターの貼付け
お礼  伊藤  - 08/11/15(土) 20:46 -

引用なし
パスワード
   ▼にぃさんへ
 早速のご回答有難うございます。
 質問を出した後、直に、回答を頂けるとは思わず
 今、家でたまたま開いてみると回答が有りました。
 お礼を申し上げます。
 マクロの内容につてい理解する充分な知識がありません。
 月曜日に会社にでて、使いこなしてみたいと思っております。
 まずは、お礼まで。

【58884】Re:シート1にシート2のデーターの貼付け
発言  Hirofumi  - 08/11/16(日) 11:53 -

引用なし
パスワード
   解決した様ですが、少し速くなる方法を考えました、
Dictionaryを使えばもっと速く成りますが
取りあえず、コードを活かして以下の様にすると幾らか速くなると思います

条件として、Sheet1、Sheet2共に「顧客コード」をKeyとして整列しても構わないと言う事にします
Upされたコードでは、Sheet2から1つ取り出して、Sheet1と比較していますが
此れを逆にします、Sheet1から1つ取り出して、Sheet2と比較しています
この時、比較を開始する位置を前回見つかった位置からとします
(両シート共に整列している居る事により、前回見つかった位置因り上には同じコード無い)

Public Sub Test_2()

  Dim i As Long
  Dim j As Long
  Dim wksS1 As Worksheet
  Dim wksS2 As Worksheet
  Dim lngCount As Long
  Dim s1max As Long
  Dim s2max As Long
  
  Set wksS1 = Sheets("補助1")
  Set wksS2 = Sheets("補助2")
  
  With wksS1
    s1max = .Range("A" & .Rows.Count).End(xlUp).Row
    '「顧客コード」をKeyとして整列
    .Range("A2:H" & s1max).Sort _
        Key1:=.Range("B2"), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
  End With
  
  With wksS2
    s2max = .Range("A" & .Rows.Count).End(xlUp).Row
    '「顧客コード」をKeyとして整列
    .Range("A2:D" & s2max).Sort _
        Key1:=.Range("B2"), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
  End With
  
  lngCount = 2
  For i = 2 To s1max
    For j = lngCount To s2max
      '「顧客コード」が等しいならForを抜ける
      If wksS1.Cells(i, 2) = wksS2.Cells(j, 2) Then
        Exit For
      End If
    Next j
    'Sheet2から「顧客コード」が見つかった場合
    If j <= s2max Then
      '顧客名、住所を転記
'      wksS1.Cells(i, 6).Resize(, 2).Value _
'          = wksS2.Cells(j, 3).Resize(, 2).Value
      wksS1.Cells(i, 7).Resize(, 2).Value _
          = wksS2.Cells(j, 3).Resize(, 2).Value
      'Sheet2の探索開始位置を変更
      lngCount = j
    Else
      'Sheet2の探索開始位置を先頭に変更
      lngCount = 2
    End If
  Next i

  Set wksS1 = Nothing
  Set wksS2 = Nothing

End Sub

【58897】Re:シート1にシート2のデーターの貼付け
お礼  伊藤  - 08/11/17(月) 9:17 -

引用なし
パスワード
   ▼Hirofumiさんへ
 ご回答頂き有難う御座います。
 以前にもHirofumiさんにお世話になり、43750`43760
 の回答を頂き、大変、活用させて頂いております。
 再度、ご回答に感謝いたします。

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