Excel VBA質問箱 IV

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

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


38115 / 76732 ←次へ | 前へ→

【43760】Re:二枚のシートで条件が一致した場合、...
回答  Hirofumi  - 06/10/24(火) 20:56 -

引用なし
パスワード
   >  Hirofumiさん教えてください。
>(26563)05.7.10に回答されたマクロを利用しておりますがシート(補助1)又は
>シート{補助2)のどちらかの行が1行の場合シート{補助3)に貼り付けず空欄に
>なってしまいます。
>シート{補助1}又はシート(補助2)の何れかが複数行の場合は巧くいきます。

何か変ですね?
このコードは、1行の時のエラー対策をし忘れたコードなので、
どちらか、若しくはどちらのシートのデータ(列見出し以下の行)が1行の場合
エラーが出て、実行がブレイクする筈なのですが?

一応、其の対策を取ったコードに書き換えて見ました

Public Sub P_顧客別売上()

  'データーの列数
  Const clngCols1 As Long = 3
  Const clngCols2 As Long = 8
 
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntList1 As Variant
  Dim lngRow1 As Long
 
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntList2 As Variant
  Dim lngRow2 As Long
 
  Dim rngResult1 As Range
  Dim rngResult2 As Range
  Dim lngWrite As Long
 
  frmSprint.Hide
 
  '補助2のA1を基準とする。(Listの左上隅)
  Set rngList1 = Worksheets("補助2").Cells(1, "A")
 
  '補助1のA1を基準とする。
  Set rngList2 = Worksheets("補助1").Cells(1, "A")
 
  '出力するシートの基準位置を設定
  Set rngResult1 = Worksheets("補助3").Cells(1, "J")
  Set rngResult2 = Worksheets("補助3").Cells(1, "A")
  
  With rngList1
    '行数を取得
    lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd1 <= 0 Then
      GoTo Wayout
    End If
    '番号列を配列に取得
    vntList1 = .Offset(1).Resize(lngEnd1 + 1).Value '★変更
  End With
 
  With rngList2
    '行数を取得
    lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd2 <= 0 Then
      GoTo Wayout
    End If
    '番号列を配列に取得
    vntList2 = .Offset(1).Resize(lngEnd2 + 1).Value '★変更
  End With

  Application.ScreenUpdating = False
 
  ' 前の検索結果をクリアする
  rngResult1.Parent.Cells.Clear
 
  '列見出しの出力
  rngList1.Resize(, clngCols2).Copy Destination:=rngResult2
  rngList2.Resize(, clngCols1).Copy Destination:=rngResult1
  '出力行の初期化
  lngWrite = 1
 
  '補助2の比較位置
  lngRow1 = 1
  '補助1の比較位置
  lngRow2 = 1
  '補助2若しくは補助1が最終行に達するまで繰返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntList1(lngRow1, 1)
      Case Is = vntList2(lngRow2, 1) 'Matchしたした場合
        rngList2.Offset(lngRow2).Resize(, clngCols1).Copy _
              Destination:=rngResult1.Offset(lngWrite)
        rngList1.Offset(lngRow1).Resize(, clngCols2).Copy _
              Destination:=rngResult2.Offset(lngWrite)
        lngWrite = lngWrite + 1
        '両Sheetの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntList2(lngRow2, 1) '補助1固有行の場合
        '補助1の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(lngRow2, 1) '補助2固有行の場合
        '補助2の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
Wayout:
    Set rngList1 = Nothing
    Set rngList2 = Nothing
    Set rngResult1 = Nothing
    Set rngResult2 = Nothing
  
    Application.ScreenUpdating = True
  
End Sub

1 hits

【43750】二枚のシートで条件が一致した場合、別シートに貼り付ける。 伊藤 06/10/24(火) 17:13 質問
【43760】Re:二枚のシートで条件が一致した場合、... Hirofumi 06/10/24(火) 20:56 回答
【43761】Re:二枚のシートで条件が一致した場合、... Hirofumi 06/10/24(火) 22:14 回答
【43763】Re:二枚のシートで条件が一致した場合、... 伊藤 06/10/25(水) 9:37 お礼
【43768】Re:二枚のシートで条件が一致した場合、別... 伊藤 06/10/25(水) 11:16 お礼

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