Excel VBA質問箱 IV

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

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


24696 / 76738 ←次へ | 前へ→

【57390】Re:2つの条件での分岐・書き込み
回答  Hirofumi  - 08/8/17(日) 0:39 -

引用なし
パスワード
   どうも質問しているレイアウトと本物のレイアウトが違っている様ですし、
Matchした時の記載も、Sheet2のC列は日付で、D列以降はSheet1のD列〜Z列の転記の様なので
結果の出力を配列を使ってC列に一気に出力するのでは無く、1行づつ転記する様に変更しました

尚、以下4つのプロシージャは、「Sub DataMatch」の時と同じ物を使います

 Private Function GetBasicData
 Private Sub DataRestore
 Private Sub DataSort
 Private Function DataCompare

以下を上記のプロシージャと同じ標準モジュールに記述して下さい

Option Explicit
Option Compare Text

Public Sub DataMatch3()

  '◆Sheet1のデータ列数(A列〜Z列)
  Const clngColumns1 As Long = 26
  '◆Sheet2のデータ列数(A列〜Z列)
  Const clngColumns2 As Long = 26
  '◆Sheet1からSheet2転記する先頭列位置(基準セル位置からの列の列Offsetを指定)
  Const clngStart As Long = 3
  '◆転記する列数(D列〜Z列の23列)
  Const clngNumb As Long = 23
  
  Dim i As Long
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim lngMatch As Long
  Dim lngAppend As Long
  Dim strProm As String

  'Sheet1データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1)
  'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1)
  
  'Sheet1の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  'Sheet2の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '追加位置の初期値
  lngAppend = lngRows2
  
  'Sheet1のシートの比較位置
  lngComp1 = 1
  'Sheet2のシートの比較位置
  lngComp2 = 1
  'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        With rngList2
          '日付を記入
          .Offset(lngComp2, clngStart - 1).Value = Date
          'Sheet1のD列以降を転記
          rngList1.Offset(lngComp1, clngStart).Resize(, clngNumb).Copy _
              Destination:=.Offset(lngComp2, clngStart)
        End With
        'Sheet1、Sheet2のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        lngComp2 = lngComp2 + 1
      Case Is = -1 'Sheet1の固有値の場合
        'Sheet2の最終行にデータを追加
        lngAppend = lngAppend + 1
        With rngList2
          'A、B列を転記
          For i = 0 To UBound(vntKeys2)
            .Offset(lngAppend, vntKeys2(i)).Value = vntList1(i)(lngComp1, 1)
          Next i
          'Sheet1のD列以降を転記
          rngList1.Offset(lngComp1, clngStart).Resize(, clngNumb).Copy _
              Destination:=.Offset(lngAppend, clngStart)
        End With
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 'Sheet2の固有値の場合
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  'Sheet1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  'Sheet2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

4 hits

【57381】2つの条件での分岐・書き込み へろへろサラリーマン 08/8/16(土) 17:36 質問
【57382】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 18:38 回答
【57383】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 19:10 回答
【57386】Re:2つの条件での分岐・書き込み へろへろサラリーマン 08/8/16(土) 20:52 質問
【57388】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 23:08 回答
【57389】Re:2つの条件での分岐・書き込み Hirofumi 08/8/16(土) 23:19 回答
【57390】Re:2つの条件での分岐・書き込み Hirofumi 08/8/17(日) 0:39 回答
【57393】Re:2つの条件での分岐・書き込み へろへろサラリーマン 08/8/17(日) 15:33 発言
【57384】Re:2つの条件での分岐・書き込み kanabun 08/8/16(土) 19:12 発言
【57385】Re:2つの条件での分岐・書き込み へろへろサラリーマン 08/8/16(土) 19:57 発言

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