Excel VBA質問箱 IV

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

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


23217 / 76732 ←次へ | 前へ→

【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
1 hits

【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 お礼

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