Excel VBA質問箱 IV

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

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


67944 / 76738 ←次へ | 前へ→

【13341】Re:データを比較して別のシートに貼り付けたいのですが。。
回答  Hirofumi E-MAIL  - 04/5/2(日) 19:19 -

引用なし
パスワード
   Sheet1、Sheet2をソートしても善いならこんなやり方も在ります
やはり1行づつ比較している事には変わり無いんだけどね?
データの例が少ないので検証不足で上手く行かなかったらゴメン
また、オートフィルタは使っていません

ただ、以下のことが気に成ります
>またオートフィルターで項目1が「未定」のものを選びますが、
>その際にシート2のデータと照らし合わせて、以前と変わらない
>データはそのままに、シート2にないデータは削除、新規のデータ
>のみを貼り付けたいのですが。この場合、次のようにしたいのです。
「シート2にないデータは削除」てシート1から?

尚、ここで使っている方法を先に説明しておきます
実際にトランプ等で試して見ると解りやすいと思います

ここでは、トランプを例に取って説明します
なんでも善いのですが、例えばハートの山とクラブの山を使います
1 、先ず、ハートの山、クラブの山から適当に何枚かづつ引き抜きます
2 、次に、夫々の山を、下に行くほど数が大きく成る様に積み上げます
 要は、夫々の山を昇順にソートする
3 、ここからLoopに入ります
4 、夫々の山の上から1枚ずつ引きます
5 、引いた札の値が、例えばハートの方がクラブより小さい場合
 この値はハートの山固有の値と成ります (ハートの山にだけ有る値の札)
 理由は、両方の山共ソートして有るので、クラブの山には
 この値未満の値が無い為、固有と決定できます
6 、引いたハートの札を棄て、また、ハートの山の上から1枚引きます
7 、此れを、先のクラブの札と値を比較します
8 、こんどは、クラブの札の値が、ハートの札の値より小さく成りました
9 、5と同様の理由でこれはクラブの山固有の値の札と成ります
10 、クラブの札を棄て、クラブの山の上から1枚引き、先のハートの札の値と比較します
11 、今度は、両方の値が同じと成りました
12 、当然、これは共有の値と成ります
13 、両方の札を棄て、両方の山の上から1枚づつ引き比較します
14 、此れを、どちらかの山が無くなるまで繰り返します (Loopを抜ける)
15 、どちらかの山に札が残った場合、其の札はその山固有の物と成ります

上記の考え方でコードを作ると以下の要に成ります
尚、ソートにExcelの並べ替えを使用する場合、比較順序がTextCompareの扱いに成るので
モジュールの先頭で「Option Compare Text」をして置いて下さい

以下を標準モジュールに記述してください

Option Explicit
Option Compare Text

Public Sub DataMatch()

  Const strExclusion As String = "決定"
  
  Dim i As Long
  Dim rngATop As Range
  Dim lngAEnd As Long
  Dim lngAPos As Long
  Dim vntAData As Variant
  Dim rngBTop As Range
  Dim lngBEnd As Long
  Dim lngBPos As Long
  Dim vntBData As Variant
  Dim lngWrite As Long
  Dim lngCol As Long
  
  '画面の更新の停止
  Application.ScreenUpdating = False

  'Sheet1の左上(番号)のセルを設定
  Set rngATop = Worksheets("Sheet1").Cells(1, 1)
  'Sheet1をソートして、列数、最終行を取得
  ListSorting rngATop, 1, lngAEnd, lngCol
  'Sheet1の読み込みの先頭行を設定
  lngAPos = rngATop.Row
  
  'Sheet2の左上(番号)のセルを設定
  Set rngBTop = Worksheets("Sheet2").Cells(1, 1)
  'Sheet2をソートして、列数、最終行を取得
  ListSorting rngBTop, 1, lngBEnd
  'Sheet2の読み込みの先頭行を設定
  lngBPos = rngBTop.Row
  '出力行初期値を設定
  lngWrite = lngBPos + lngBEnd
  
  'Sheet1、Sheet2のデータ先頭行の先読み
  vntAData = DataRead(rngATop, lngAPos, lngCol)
  vntBData = DataRead(rngBTop, lngBPos, lngCol)
  'Sheet1、Sheet2どちらかが無くなるまで繰り返し
  Do Until lngAPos > lngAEnd Or lngBPos > lngBEnd
    If vntAData(1, 4) = strExclusion Then
      lngAPos = lngAPos + 1
      vntAData = DataRead(rngATop, lngAPos, lngCol)
    Else
      Select Case vntAData(1, 1)
        Case Is = vntBData(1, 1) 'Key項目がMatchした場合
          'データに変更が有った場合
          If Not DataCheck(vntAData, vntBData) Then
            'Sheet1の行をSheet2の行に置き換え
            DataOut rngATop, lngAPos, _
                lngCol, rngBTop, lngBPos
          End If
          'Sheet1、Sheet2の読み込み位置を更新
          lngAPos = lngAPos + 1
          lngBPos = lngBPos + 1
          'Sheet1、Sheet2の次行の読み込み
          vntAData = DataRead(rngATop, lngAPos, lngCol)
          vntBData = DataRead(rngBTop, lngBPos, lngCol)
        Case Is < vntBData(1, 1) 'Sheet1の固有値の場合
          'Sheet1の行をSheet2の最終行に追加
          DataOut rngATop, lngAPos, _
                lngCol, rngBTop, lngWrite
          'Sheet1の読み込み、出力行位置を更新
          lngAPos = lngAPos + 1
          lngWrite = lngWrite + 1
          'Sheet1の次行の読み込み
          vntAData = DataRead(rngATop, lngAPos, lngCol)
        Case Is > vntBData(1, 1) 'Sheet2の固有値の場合
          'Sheet2の行を削除
          rngBTop.Offset(lngBPos).EntireRow.Delete
          '行削除の為、最終行位置、出力行位置を更新
          lngBEnd = lngBEnd - 1
          lngWrite = lngWrite - 1
          'Sheet2の次行の読み込み
          vntBData = DataRead(rngBTop, lngBPos, lngCol)
      End Select
    End If
  Loop

  'Sheet1に行が残っている場合の処理
  For i = lngAPos To lngAEnd
    vntAData = DataRead(rngATop, i, lngCol)
    If vntAData(1, 4) <> strExclusion Then
      'Sheet1の行をSheet2の最終行に追加
      DataOut rngATop, i, lngCol, rngBTop, lngWrite
      '出力行位置を更新
      lngWrite = lngWrite + 1
    End If
  Next i
  'Sheet2に行が残っている場合の処理
  For i = lngBEnd To lngBPos Step -1
    'Sheet2の行を削除
    rngBTop.Offset(i).EntireRow.Delete
  Next i

  Set rngATop = Nothing
  Set rngBTop = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が終了しました"
  
End Sub

Private Function DataRead(rngRead As Range, _
            lngPos As Long, _
            lngCol As Long) As Variant

' データの読み込み

  DataRead _
    = rngRead.Offset(lngPos).Resize(, lngCol).Value
  
End Function

Private Sub DataOut(rngCopy As Range, _
          lngCopyRow As Long, _
          lngColCount As Long, _
          rngDestination As Range, _
          lngWrite As Long)

' 転記先えの出力

  rngCopy.Offset(lngCopyRow).Resize(, lngColCount).Copy _
        Destination:=rngDestination.Offset(lngWrite)

End Sub

Private Sub ListSorting(rngListTop As Range, _
          lngKey As Long, _
          lngRowEnd As Long, _
          Optional lngColCount As Long)
          
'  ListのKey項目に就いての並べ替えと、データ取得

  Dim rngScope As Range
  
  Set rngScope = rngListTop.CurrentRegion
  With rngScope
    .Sort Key1:=.Item(1, lngKey), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlStroke
    lngRowEnd = .Rows.Count - 1
    lngColCount = .Columns.Count
  End With
  Set rngScope = Nothing

End Sub

Private Function DataCheck(vntListA As Variant, _
            vntListB As Variant) As Boolean

'  行の比較

  Dim i As Long
  
  DataCheck = True
  For i = 1 To UBound(vntListA, 2)
    If vntListA(1, i) <> vntListB(1, i) Then
      DataCheck = False
      Exit Function
    End If
  Next i
  
End Function

0 hits

【13272】データを比較して別のシートに貼り付けたいのですが。。 natuko 04/4/29(木) 21:03 質問
【13285】Re:データを比較して別のシートに貼り付け... Jaka 04/4/30(金) 10:57 発言
【13289】Re:データを比較して別のシートに貼り付け... natuko 04/4/30(金) 13:36 質問
【13290】Re:データを比較して別のシートに貼り付け... Asaki 04/4/30(金) 13:48 回答
【13293】Re:データを比較して別のシートに貼り付け... Jaka 04/4/30(金) 17:14 回答
【13341】Re:データを比較して別のシートに貼り付け... Hirofumi 04/5/2(日) 19:19 回答
【13352】Re:データを比較して別のシートに貼り付け... Hirofumi 04/5/2(日) 21:34 発言

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