|
▼はる さん:
いろいろアップすると混乱されるかもしれませんが・・・
もし、登場する名前に重複がない、かつ、左側の名前と右側の名前は順番以外は1:1だという前提なら
以下のように並び替えだけのコードでも大丈夫ですのでご参考まで。
Sub Sample6()
Dim wkR1 As Range
Dim myR1 As Range
Dim wkR2 As Range
Dim myR2 As Range
Dim y As Long
With Sheets("Sheet1")
y = .Range("A" & .Rows.Count).End(xlUp).Row
Set myR1 = .Range("A7:G" & y) '左側のデータ域
Set myR2 = .Range("H7:M" & y) '右側のデータ域
Set wkR1 = myR1.Columns(myR1.Columns.Count) '左側の作業域
Set wkR2 = myR2.Columns(myR2.Columns.Count) '右側の作業域
'左側領域を名前のみで並び替え
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Columns("A"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange myR1
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'右側領域を名前のみで並び替え
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Columns("H"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange myR2
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wkR1.Formula = "=IF(F7=0,1,0)"
wkR1.Value = wkR1.Value
wkR2.Value = wkR1.Value
'左側領域を数値有り無しで並び替え
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=wkR1, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange myR1
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'右側領域を数値有り無しで並び替え
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=wkR2, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange myR2
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
wkR1.Clear
wkR2.Clear
End Sub
|
|