| |
古いものを取り出してきて申し訳ないです。
このサンプルを利用して、
sheet1
2
4
2
1
sheet2
1 12
2 24
3 34
4 45
↓
sheet3
2 24
4 45
2 24
1 12
に並べようとしたんですが、いざやってみると、
例.
(sheet1)
2
4
2
1
(sheet2)
1 12
2 24
3 34
4 45
↓
(sheet3)
1 12
2 24
4 45
となってしまいました。
重複した値を消さずに、かつ順番を変えずにするには
どこをいじればいいですか?
▼Hirofumi さん：
>試して無いけど、こんな物で出来るかも？
>ただし、夫々のシートには、列見出しが有る物とします
>また、Sheet1、Sheet2共に同一シート内では重複が無い物とします
>
>Option Explicit
>
>Public Sub UpDate()
>
> '"Sheet1"のデータ列数（A列）
> Const clngColumns1 As Long = 1
> '"Sheet1"の比較Key列位置（基準からA列の列Offset値）
> Const clngKeys1 As Long = 0
>
> '"Sheet2"のデータ列数（A列〜C列）
> Const clngColumns2 As Long = 3
> '"Sheet2"の比較Key列位置（基準からA列の列Offset値）
> Const clngKeys2 As Long = 0
>
> Dim i As Long
> Dim rngList1 As Range
> Dim lngEnd1 As Long
> Dim vntData1 As Variant
> Dim lngRow1 As Long
> Dim rngList2 As Range
> Dim lngEnd2 As Long
> Dim vntData2 As Variant
> Dim lngRow2 As Long
> Dim rngResult As Range
> Dim lngWrite As Long
> Dim strProm As String
>
> 'Sheet1のA1を基準とします（列見出し先頭のセル位置）
> Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
>
> 'Sheet2のA1を基準とする（列見出し先頭のセル位置）
> Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
>
> 'Sheet3のA1を基準とする（列見出し先頭のセル位置）
> Set rngResult = Worksheets("Sheet3").Cells(1, "A")
>
> '画面更新を停止
> Application.ScreenUpdating = False
>
> '"Sheet1"データの基準に就いて基礎データの取得
> If Not GetBasicData(rngList1, lngEnd1, _
> clngColumns1, clngKeys1, vntData1) Then
> strProm = rngList1.Parent.Name & "にデータが有りません"
> GoTo Wayout
> End If
>
> '"Sheet2"データの基準に就いて基礎データの取得
> If Not GetBasicData(rngList2, lngEnd2, _
> clngColumns2, clngKeys2, vntData2) Then
> strProm = rngList2.Parent.Name & "にデータが有りません"
> GoTo Wayout
> End If
>
> '"Sheet1"の比較位置
> lngRow1 = 1
> '"Sheet2"の比較位置
> lngRow2 = 1
> '"Sheet1"若しくは、"Sheet2"が最終行に達するまで繰り返し
> Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
> '比較結果に就いて
> Select Case vntData1(lngRow1, 1)
> Case Is = vntData2(lngRow2, 1) 'Matchiした場合
> '"Sheet3"に"Sheet2"のA〜C列のデータを出力
> lngWrite = lngWrite + 1
> rngList2.Offset(lngRow2).Resize(, clngColumns2).Copy _
> Destination:=rngResult.Offset(lngWrite)
> '両データの比較位置の更新
> lngRow1 = lngRow1 + 1
> lngRow2 = lngRow2 + 1
> Case Is > vntData2(lngRow2, 1) '"Sheet2"固有値の場合
> '"Sheet2"の比較位置を更新
> lngRow2 = lngRow2 + 1
> Case Is < vntData2(lngRow2, 1) '"Sheet1"固有値の場合
> '"Sheet1"の比較位置を更新
> lngRow1 = lngRow1 + 1
> End Select
> Loop
>
> '"Sheet1"データの復旧
> DataRestore rngList1, lngEnd1, clngColumns1
>
> '"Sheet2"データの復旧
> DataRestore rngList2, lngEnd2, clngColumns2
>
> strProm = "処理が完了しました"
>
>Wayout:
>
> '画面更新を再開
> Application.ScreenUpdating = True
>
> Set rngList1 = Nothing
> Set rngList2 = Nothing
> Set rngResult = Nothing
>
> MsgBox strProm, vbInformation
>
>End Sub
>
>Private Function GetBasicData(rngList As Range, _
> lngRows As Long, _
> lngColumns As Long, _
> lngKeys As Long, _
> vntData As Variant) As Boolean
>
> Dim i As Long
> Dim lngNumb() As Long
>
> '基準に就いて
> With rngList
> '行数を取得
> lngRows = .Offset(65536 - .Row, _
> lngKeys).End(xlUp).Row - .Row
> 'データが無ければFunctionを抜ける(戻り値=False)
> If lngRows < 0 Then
> Exit Function
> End If
> '復帰用整列Keyを作成
> ReDim lngNumb(1 To lngRows, 1 To 1)
> For i = 1 To lngRows
> lngNumb(i, 1) = i
> Next i
> '復帰用Keyの出力列を挿入
> .Offset(1, lngColumns).EntireColumn.Insert
> '復帰用Keyの出力
> .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
> 'データをlngKeys列で整列
> .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
> Key1:=.Offset(1, lngKeys), Order1:=xlAscending, _
> Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
> Orientation:=xlTopToBottom, SortMethod:=xlStroke
> 'データを配列に取得
> vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
> End With
>
> GetBasicData = True
>
>End Function
>
>Private Sub DataRestore(rngList As Range, _
> lngRows As Long, _
> lngColumns As Long)
>
> 'データの復旧
> With rngList
> '元データ順位を復帰
> .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
> Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
> Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
> Orientation:=xlTopToBottom, SortMethod:=xlStroke
>
> '復帰用Key列を削除
> .Offset(, lngColumns).EntireColumn.Delete
> End With
>
>End Sub
|
|
黄身
- 09/11/30(月) 3:51 -
