Excel VBA質問箱 IV

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

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


17237 / 76738 ←次へ | 前へ→

【64958】Re:列によるソート
回答  Hirofumi  - 10/3/29(月) 23:31 -

引用なし
パスワード
   こんなのでは?

C列、G列を作業列に使用します

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim j As Long
  Dim lngRows1 As Long
  Dim lngRows2 As Long
  Dim vntData1 As Variant
  Dim vntData2 As Variant
  Dim strProm As String
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With ActiveSheet
    'A列グループ、E列グループを先頭列で整列
    DataSort .Columns("A:B"), Range("A1")
    DataSort .Columns("E:F"), Range("E1")
    'A列グループ、E列グループの最終行を取得
    lngRows1 = .Cells(Rows.Count, "A").End(xlUp).Row
    lngRows2 = .Cells(Rows.Count, "E").End(xlUp).Row
    'A列グループのA列をC列にCopy、E列グループのE列をG列にCopyします
    .Columns("A").Copy Destination:=.Columns("C")
    .Columns("E").Copy Destination:=.Columns("G")
    'A列、E列を比較
    i = 1: j = 1
    vntData1 = .Cells(i, "A").Value
    vntData2 = .Cells(j, "E").Value
    'A列、E列が共に最終行に成るまで繰り返し
    Do Until IsEmpty(vntData1) And IsEmpty(vntData2)
      'A列が最終行に達したら
      If IsEmpty(vntData1) Then
        lngRows1 = lngRows1 + 1
        .Cells(lngRows1, "C").Value = vntData2
        j = j + 1
      'E列が最終行に達したら
      ElseIf IsEmpty(vntData2) Then
        lngRows2 = lngRows2 + 1
        .Cells(lngRows2, "G").Value = vntData1
        i = i + 1
      Else
        Select Case vntData1
          Case Is = vntData2 'A、E列の値が同じなら何もしない
            i = i + 1
            j = j + 1
          Case Is < vntData2 'A列だけに在る値
            'G列最終行にA列の値を追加
            lngRows2 = lngRows2 + 1
            .Cells(lngRows2, "G").Value = vntData1
            i = i + 1
          Case Else 'E列だけに在る値
            'C列最終行にE列の値を追加
            lngRows1 = lngRows1 + 1
            .Cells(lngRows1, "C").Value = vntData2
            j = j + 1
        End Select
      End If
      vntData1 = .Cells(i, "A").Value
      vntData2 = .Cells(j, "E").Value
    Loop
    'A列グループをC列で、E列グループをG列で整列
    DataSort .Columns("A:C"), Range("C1")
    DataSort .Columns("E:G"), Range("G1")
    'C列、G列を消去
    .Columns("C").ClearContents
    .Columns("G").ClearContents
  End With
    
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  MsgBox strProm, vbInformation
     
End Sub

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

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

End Sub

0 hits

【64902】列によるソート もーはん 10/3/25(木) 22:10 質問
【64903】Re:列によるソート kanabun 10/3/25(木) 23:10 発言
【64947】Re:列によるソート もーはん 10/3/29(月) 10:09 質問
【64951】Re:列によるソート kanabun 10/3/29(月) 13:18 発言
【64953】Re:列によるソート もーはん 10/3/29(月) 15:47 発言
【64954】Re:列によるソート kanabun 10/3/29(月) 16:42 発言
【64961】Re:列によるソート もーはん 10/3/30(火) 13:02 発言
【64962】Re:列によるソート kanabun 10/3/30(火) 14:03 発言
【64965】Re:列によるソート もーはん 10/3/30(火) 17:29 お礼
【64958】Re:列によるソート Hirofumi 10/3/29(月) 23:31 回答

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