Excel VBA質問箱 IV

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

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


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

【33308】数字の比較について 超初心者 06/1/8(日) 17:21 質問[未読]
【33311】Re:数字の比較について だるま 06/1/8(日) 19:22 回答[未読]
【33313】Re:数字の比較について 超初心者 06/1/8(日) 20:57 お礼[未読]
【33314】Re:数字の比較について 超初心者 06/1/8(日) 21:41 質問[未読]
【33318】Re:数字の比較について Hirofumi 06/1/8(日) 22:53 回答[未読]

【33308】数字の比較について
質問  超初心者  - 06/1/8(日) 17:21 -

引用なし
パスワード
   VBAを始めたばかりの超初心者ですが、よろしくお願いします。
まず、EXCELのシート1の1列にあるデータ(1.)があります。
シート2の1列にもあるデータ(2.)が入っております。

この時、2.をシート1の2列目に、数字が同じ物は横に並べてコピーして、
数字が違うものは間隔を空けてコピーしたいのですが、これをVBAで作ることはできるのでしょうか?

以下のような表を作りたいのでよろしくお願いします。


1列目  2列目   差
      50  −50
100  100   0
     150 −150
200       200
250  250   0

*2列目は違うシートからコピーして持ってくる

【33311】Re:数字の比較について
回答  だるま WEB  - 06/1/8(日) 19:22 -

引用なし
パスワード
   こんな感じでしょうか。^d^

(両列とも昇順に並べ替え済という前提です。)

Sub シンクロ()
  Dim rngA As Range, rngB As Range
  Dim AA As Variant, BB As Variant
  Dim cA As Long, cB As Long, C As Long
  Dim cAmax As Long, cBmax As Long
  Dim Dest As Variant
  Dim A As Variant, B As Variant
  
  With Worksheets("Sheet1")
    Set rngA = .Range("A1", .Range("A65536").End(xlUp))
  End With
  
  With Worksheets("Sheet2")
    Set rngB = .Range("A1", .Range("A65536").End(xlUp))
  End With
  
  AA = rngA.Value: BB = rngB.Value
  cAmax = UBound(AA): cBmax = UBound(BB)
  
  ReDim Dest(1 To cAmax + cBmax, 1 To 3)
  
  cA = 1: cB = 1: C = 1
  Do Until cA > cAmax Or cB > cBmax
    A = AA(cA, 1): B = BB(cB, 1)
    If A = B Then
      Dest(C, 1) = A
      cA = cA + 1
      Dest(C, 2) = B
      cB = cB + 1
      Dest(C, 3) = 0
    ElseIf A < B Then
      Dest(C, 1) = A
      cA = cA + 1
      Dest(C, 3) = A
    Else
      Dest(C, 2) = B
      cB = cB + 1
      Dest(C, 3) = -B
    End If
    C = C + 1
  Loop
  
  Do Until cA > cAmax
    A = AA(cA, 1)
    Dest(C, 1) = A
    cA = cA + 1
    Dest(C, 3) = A
    C = C + 1
  Loop
  
  Do Until cB > cBmax
    B = BB(cB, 1)
    Dest(C, 2) = B
    cB = cB + 1
    Dest(C, 3) = -B
    C = C + 1
  Loop
  
  Worksheets("Sheet1").Range("A1").Resize(cAmax + cBmax, 3).Value = Dest
  
  Set rngA = Nothing
  Set rngB = Nothing
End Sub

【33313】Re:数字の比較について
お礼  超初心者  - 06/1/8(日) 20:57 -

引用なし
パスワード
   ▼だるま さん:
さっそくの回答ありがとうございました^^
ただ、C列の解は求まるのですが、A列とB列がシンクロしてくれませんでした。
なぜでしょうか。。
プログラムを分析しましたが、分かりませんでした。

【33314】Re:数字の比較について
質問  超初心者  - 06/1/8(日) 21:41 -

引用なし
パスワード
   ▼超初心者 さん:
>▼だるま さん:
>さっそくの回答ありがとうございました^^
>ただ、C列の解は求まるのですが、A列とB列がシンクロしてくれませんでした。
>なぜでしょうか。。
>プログラムを分析しましたが、分かりませんでした。

すいません。私のミスでした・・
書式が変わると実行時におかしくなっていたようです。

これを応用して、
 A   B    C    D  
        50   みかん
100 鉛筆  100  りんご 
        150  なし
200 メモ      
250 ノート 250  メロン

など、他のデータを持ってきたい場合はどこの値を変えればいいのでしょうか?

A列B列はあらかじめシート1にあり、C列D列はシート2のA列B列にあって
↑のAとCで値をそろえて、BとDはそのまま持ってくるだけです。

すいませんがよろしくお願いします。。

【33318】Re:数字の比較について
回答  Hirofumi  - 06/1/8(日) 22:53 -

引用なし
パスワード
   Sheet1が以下の様

   A    B
1 100  鉛筆
2 200  メモ
3 250  ノート

Sheet2が以下の様

  A     B  
1 50   みかん
2 100  りんご
3 150  なし
4 250  メロン

基本的に だるま さん と同じロジックのコードです

Option Explicit

Public Sub Extraction()

  'データの列数
  Const clngColumns As Long = 2
  
  Dim i As Long
  Dim lngEnd1 As Long
  Dim vntList1 As Variant
  Dim lngRow1 As Long
  Dim lngEnd2 As Long
  Dim vntList2 As Variant
  Dim lngRow2 As Long
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim strProm As String
  
  'Sheet1のA1を基準とします(Listの左上隅)
  With Worksheets("Sheet1").Cells(1, "A")
    '行数を取得
    lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    If lngEnd1 <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A、B列を配列に取得
    vntList1 = .Resize(lngEnd1, clngColumns).Value
  End With
  
  'Sheet2のA1を基準とする
  With Worksheets("Sheet2").Cells(1, "A")
    '行数を取得
    lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    If lngEnd1 <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A、B列を配列に取得
    vntList2 = .Resize(lngEnd2, clngColumns).Value
  End With
  
  '結果出力用配列を確保
  ReDim vntResult(1 To lngEnd1 + lngEnd2, 1 To clngColumns * 2)
  
  '書き込み行を初期値に(Offse値)
  lngWrite = 0
  'Sheet1のA列の比較位置
  lngRow1 = 1
  'Sheet2のA列の比較位置
  lngRow2 = 1
  'Sheet1のA列若しくは,Sheet2のA列が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '出力位置を更新
    lngWrite = lngWrite + 1
    '比較結果に就いて
    Select Case vntList1(lngRow1, 1)
      Case Is = vntList2(lngRow2, 1) 'Matchiした場合
        'データを配列に代入
        vntResult(lngWrite, 1) = vntList1(lngRow1, 1)
        vntResult(lngWrite, 2) = vntList1(lngRow1, 2)
        vntResult(lngWrite, 3) = vntList2(lngRow2, 1)
        vntResult(lngWrite, 4) = vntList2(lngRow2, 2)
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntList2(lngRow2, 1) 'Sheet2のA列固有行の場合
        'Sheet2のデータを配列に代入
        vntResult(lngWrite, 3) = vntList2(lngRow2, 1)
        vntResult(lngWrite, 4) = vntList2(lngRow2, 2)
        'Sheet2のA列の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(lngRow2, 1) 'Sheet1のA列固有行の場合
        'Sheet1のデータを配列に代入
        vntResult(lngWrite, 1) = vntList1(lngRow1, 1)
        vntResult(lngWrite, 2) = vntList1(lngRow1, 2)
        'Sheet1のA列の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
  '残ったSheet1のA列の固有値を出力
  For i = lngRow1 To lngEnd1
    '出力位置を更新
    lngWrite = lngWrite + 1
    'データを配列に代入
    vntResult(lngWrite, 1) = vntList1(i, 1)
    vntResult(lngWrite, 2) = vntList1(i, 2)
  Next i
  
  '残ったSheet2のA列の固有値を出力
  For i = lngRow2 To lngEnd2
    '出力位置を更新
    lngWrite = lngWrite + 1
    'データを配列に代入
    vntResult(lngWrite, 3) = vntList2(i, 1)
    vntResult(lngWrite, 4) = vntList2(i, 2)
  Next i
  
  Application.ScreenUpdating = False
  
  '抽出データを書きこむ位置を指定し結果配列を出力
  With Worksheets("Sheet1").Cells(1, "A")
    .Resize(lngWrite, clngColumns * 2).Value = vntResult
  End With
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:

  MsgBox strProm, vbInformation
  
End Sub

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