Excel VBA質問箱 IV

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

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


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

【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 発言[未読]

【57381】2つの条件での分岐・書き込み
質問  へろへろサラリーマン  - 08/8/16(土) 17:36 -

引用なし
パスワード
   はじめて書き込みします。助けてください。
 シート1のA列に社名、B列に氏名があります。シート2のAB列にもいくつかの社名・氏名があるとして、シート1のA・Bがシート2のA・Bに合致したときにはシート2のC列に"合致"と記入、合致しなければシート2の最終行に社名と氏名を書き込むとの作業をしたいのです。図示をすると

シート1            シート2
 A     B ・・・       A      B      C
 社名    氏名       社名     氏名     判定
 BB商店  田中 五郎    AA商事   川村 三郎
 RA商事  山田 1郎    RA商事   山田 1郎  合致
 ・     ・           BB商店   田中 五郎    ’・・新規
 ・     ・

といったような結果が得たいのです。
 エクセル2003ですが実際に使用する人にはもちろんプログラムや関数の知識はまったくありません。さらにシート1は毎日入れ替えますのでセル上に関数を入力しておくことは出来ません。
 またアクセス等データベースソフトを使うことが出来ない点も含め、教えていただきたいです。

 自分で試した構文では出来ませんでした。助けてください。よろしくおねがいします。
 

【57382】Re:2つの条件での分岐・書き込み
回答  Hirofumi  - 08/8/16(土) 18:38 -

引用なし
パスワード
   Dictionary使った方が簡単だと思うけど
こんなのも有ります

Option Explicit
'Option Compare Text

Public Sub DataMatch()

  'Sheet1のデータ列数(A列〜B列)
  Const clngColumns1 As Long = 2
  'Sheet2のデータ列数(A列〜C列)
  Const clngColumns2 As Long = 3
  
  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 vntResult As Variant
  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
  '結果出力用配列を確保
  ReDim vntResult(1 To lngRows2, 1 To 1)
  '追加位置を記録
  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した場合
        '合致を記入
        vntResult(lngComp2, 1) = "合致"
        'Sheet1、Sheet2のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        lngComp2 = lngComp2 + 1
      Case Is = -1 'Sheet1の固有値の場合
        'Sheet2の最終行にデータを追加
        lngAppend = lngAppend + 1
        With rngList2.Offset(lngAppend)
          .Value = vntList1(0)(lngComp1, 1)
          .Offset(, 1).Value = vntList1(1)(lngComp1, 1)
        End With
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 'Sheet2の固有値の場合
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  '結果を出力
  rngList2.Offset(1, clngColumns2 - 1).Resize(lngRows2).Value = vntResult
  
  '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

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                vntKeys As Variant, _
                vntData As Variant) As Boolean

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
    Next i
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)

  With rngList
    '元データ順位を復帰
    DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngColumns)
    '復帰用Key列を削除
    .Offset(1, lngColumns).EntireColumn.Delete
  End With

End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
            vntKeys2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
  
  '比較位置がDataEndを超えた場合
  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
    DataCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    DataCompare = -1
    Exit Function
  End If
    
  '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
  lngMax = UBound(vntKeys1, 1)
  
  '1行のKeyを先頭から比較
  For i = 0 To lngMax
    'もし、Keyが不一致なら
    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
      'Forを抜ける
      Exit For
    End If
  Next i
  
  'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
  If i > lngMax Then
    '戻り値の値として、「等しい」を返す
    DataCompare = 0
  Else
    'vntKeys1の値が、vntKeys2の値因り小さい場合
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      '戻り値の値として、「小さい」を返す
      DataCompare = -1
    Else
      '戻り値の値として、「大きい」を返す
      DataCompare = 1
    End If
  End If
  
End Function

【57383】Re:2つの条件での分岐・書き込み
回答  Hirofumi  - 08/8/16(土) 19:10 -

引用なし
パスワード
   Dictionary版

Option Explicit
'Option Compare Text

Public Sub DataMatch2()

  'Sheet1のデータ列数(A列〜B列)
  Const clngColumns1 As Long = 2
  'Sheet2のデータ列数(A列〜C列)
  Const clngColumns2 As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim rngList1 As Range
  Dim vntList As Variant
  Dim lngRows As Long
  Dim vntKeys As Variant
  Dim rngList2 As Range
  Dim vntResult As Variant
  Dim lngAppend As Long
  Dim dicIndex As Object
  Dim vntKey As Variant
  Dim strProm As String

  'Sheet1データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  'Sheetの比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys = Array(0, 1)
  
  'Sheetの比較データを保持する配列を確保
  ReDim vntList(0 To UBound(vntKeys))
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")

  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows, clngColumns2, vntKeys, vntList) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  '結果出力用配列を確保
  ReDim vntResult(1 To lngRows, 1 To 1)
  '追加位置を記録
  lngAppend = lngRows
  'DictionaryにSheet2のデータを登録
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntList(0)(i, 1) & vbTab & vntList(1)(i, 1)
      If Not .Exists(vntKey) Then
        .Item(vntKey) = i
      End If
    Next i
  End With
      
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows, clngColumns1, vntKeys, vntList) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  With dicIndex
    For i = 1 To lngRows
      vntKey = vntList(0)(i, 1) & vbTab & vntList(1)(i, 1)
      If .Exists(vntKey) Then
        vntResult(.Item(vntKey), 1) = "合致"
      Else
        'Sheet2の最終行にデータを追加
        lngAppend = lngAppend + 1
        With rngList2.Offset(lngAppend)
          .Value = vntList(0)(i, 1)
          .Offset(, 1).Value = vntList(1)(i, 1)
        End With
      End If
    Next i
  End With
  '結果を出力
  rngList2.Offset(1, clngColumns2 - 1).Resize(UBound(vntResult, 1)).Value = vntResult

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

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                vntKeys As Variant, _
                vntData As Variant) As Boolean

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

【57384】Re:2つの条件での分岐・書き込み
発言  kanabun  - 08/8/16(土) 19:12 -

引用なし
パスワード
   ▼へろへろサラリーマン さん:

こんにちは。
質問なのですが、

> さらにシート1は毎日入れ替えますので

では、シート2 のほうは入れ替えないのですか?
シート2 のほうの
C列の判定結果は 新しいシート1 との比較を書き込むなら、一度クリアしなければならないでしょう?

また、
> 合致しなければシート2の最終行に社名と氏名を書き込む
この書きこんだものは、つぎのシート1との比較を行う際には、A,B列の全データが
シート1との比較対象になるということですか?


【57385】Re:2つの条件での分岐・書き込み
発言  へろへろサラリーマン  - 08/8/16(土) 19:57 -

引用なし
パスワード
   ▼kanabun さん:

質問有り難うございます。早速ですが、

>では、シート2 のほうは入れ替えないのですか?
>シート2 のほうの
>C列の判定結果は 新しいシート1 との比較を書き込むなら、一度クリアしなければならないでしょう?

そうですね。。。「合致」という言葉をやめて更新日を「date」の形で入れることにしようと思います(サンプルをみていて思いました。)。

>また、合致しなければシート2の最終行に社名と氏名を書き込む
>この書きこんだものは、つぎのシート1との比較を行う際には、A,B列の全データがシート1との比較対象になるということですか?

 そうなんです。シート1には、社名と氏名がダブるものがある可能性があるのです。実際には書いていませんが、会社への問い合わせ内容などがシート1のD列にあるというイメージです。したがってシート2に書き込んだ直後の列で合致、若しくは更新日を入れて行きたいと思っています。

 お手数をかけます。よろしくお願いします。

【57386】Re:2つの条件での分岐・書き込み
質問  へろへろサラリーマン  - 08/8/16(土) 20:52 -

引用なし
パスワード
   ▼Hirofumi さん:

早速のご回答有り難うございます。今一生懸命自分のデータにあわせています。
まったく見たこともないようなコードで苦労していますが。。。(笑)

 あわせていて思ったのですが、後から質問を足すのはエチケット違反だと思うのですがもう少し教えてください。

 1. "合致"の代わりに更新日を入れるとすれば、
     '合致を記入

>        vntResult(lngComp2, 1) = Date

  ではエラーがでてしまいますね?プログラム的に問題ないですよね?
 2. シート2のD列に例えばシート1のC列を書き込むとすれば

        vntResult(lngComp2, 2) = vntList1(1)(lngComp1, 2)

  でいいんですかね?
 3. (lngComp2, 2) をもっと大きな(lngComp2, 24)等ににするのはNGですか?これでZ列に書き込みが出来るのかなと思ったのですが。。。インデックスが有効範囲にありませんと出ます。

 どうか迷えるサラリーマンを救ってください。(何度も書き直してしまいました)

【57388】Re:2つの条件での分岐・書き込み
回答  Hirofumi  - 08/8/16(土) 23:08 -

引用なし
パスワード
   > 1. "合致"の代わりに更新日を入れるとすれば、
>     '合致を記入
>
>>        vntResult(lngComp2, 1) = Date
>
>  ではエラーがでてしまいますね?プログラム的に問題ないですよね?

変な変更を行っていなければ上記で日付が入るはずですし
当方でのTestでは、日付が入ります


> 2. シート2のD列に例えばシート1のC列を書き込むとすれば
>
>        vntResult(lngComp2, 2) = vntList1(1)(lngComp1, 2)
>
>  でいいんですかね?

此れはNGですね、シート1のC列に就いては当然考慮していませんので
配列にC列のデータを取得していませんし、そもそも配列自体そのサイズなっていません
C列を出力したければ、以下を修正します

  'Sheet2のデータ列数(A列〜C列)
'  Const clngColumns2 As Long = 3
  Const clngColumns2 As Long = 4 '★変更(D列に書き込むならここをD列までに拡張する)

  End If
  '結果出力用配列を確保
'  ReDim vntResult(1 To lngRows2, 1 To 1)
  ReDim vntResult(1 To lngRows2, 1 To 2) '★変更
  '追加位置を記録
  lngAppend = lngRows2


Sub DataMatch()の場合

      Case Is = 0 'Matchiした場合
        '合致を記入
'        vntResult(lngComp2, 1) = "合致"
        vntResult(lngComp2, 1) = Date '★変更
        vntResult(lngComp2, 2) = rngList1.Offset(lngComp1, 3).Value '★追加
        'Sheet1、Sheet2のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        lngComp2 = lngComp2 + 1


Sub DataMatch2の場合

      If .Exists(vntKey) Then
'        vntResult(.Item(vntKey), 1) = "合致"
        vntResult(.Item(vntKey), 1) = Date '★変更
        vntResult(.Item(vntKey), 2) = rngList1.Offset(lngComp1, 3).Value '★追加
      Else


> 3. (lngComp2, 2) をもっと大きな(lngComp2, 24)等ににするのはNGですか?これでZ列に書き込みが出来るのか>>なと思ったのですが。。。インデックスが有効範囲にありませんと出ます。

NGとまでは言い切れませんが、配列のサイズがデータ量に因っては大きくなりすぎる可能性が有ります
ただ、ご自分で試して見る様ですね

変更方法は、

  '結果出力用配列を確保
'  ReDim vntResult(1 To lngRows2, 1 To 1)
  ReDim vntResult(1 To lngRows2, 1 To 24) '★変更
  '追加位置を記録
  lngAppend = lngRows2

これで使えない様ならば、コードを変更し(遅くなるのを覚悟して)、
列出力では無く、行処理にすればいいと思います

【57389】Re:2つの条件での分岐・書き込み
回答  Hirofumi  - 08/8/16(土) 23:19 -

引用なし
パスワード
   書き忘れました

結果出力用配列(vntResult)を拡張した場合
当然、

  'Sheet2のデータ列数(A列〜C列)
  Const clngColumns2 As Long = 3

も変更しなければ成りません
なぜなら、上記を例に取ると、A列〜C列にデータが有る物と見なし、
D列を作業列に使用して、マクロ終了時にD列を削除しています

【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

【57393】Re:2つの条件での分岐・書き込み
発言  へろへろサラリーマン E-MAIL  - 08/8/17(日) 15:33 -

引用なし
パスワード
   >どうも質問しているレイアウトと本物のレイアウトが違っている様ですし、

 もうしわけございません。。。冷静な対応ありがとうございます。

早速打ち込んでみます。ありがとうございます。

 結果報告については別途させていただきます。

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