Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

17231 / 76732

←次へ　｜　前へ→


	【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

2 hits

▼

【64902】列によるソート もーはん 10/3/25(木) 22:10