VBAで，特定の漢字が入っている行のみ，下のほうに

質問

ExcelのVBAでのソートについて教えていただきたいと思います。

行を並べ替える（２行目が見出し行なので，３行目以降）のですが，
或る列（C列）に特定の漢字が入っている行を，
一番下にしたいのですが，
どのようにすればよろしいでしょうか？

３行目以降のイメージとしては：

あい　う　　　え和えええ
おか　きき　　くけこ
さし　すすす　せそ和
たち　つて　　和となにぬねの
はひ　ふへ　　ほ

↓
おか　きき　　くけこ
はひ　ふへ　　ほ
あい　う　　　え和えええ
さし　すすす　せそ和
たち　つて　　和となにぬねの

上記の例のように，
「和」という文字がC列に含まれている行のみを下のほうに集め，
入っていない行を上のほうに集めたいのです。

上記はイメージなので，
実際は，
「特定の文字だけが漢字で，他はすべて平仮名」なんてことはありません。

「和」という文字がC列に含まれている行のみを下のほうに集めるという並べ替え前の
行の順序は，
必ずしも保たれている必要はありません。

Excel2000ですが，回答は他のバージョンでもいいです。
どのバージョンか断っていただくとこちらとしても参考になります。

回答No.2

Wendy02 · ベストアンサー

記録マクロでは細かいところは、ちょっと思うように行かないかもしれませんが、基本的にはには、並べ替えで出来るかと思います。

特定のバージョンのクレジットは付けませんが、その機能があればどのバージョンでも問題ありません。検索は、InputBox を取り付けてもよいと思います。

Sub Test1()
　Const sWORD As String = "和"
　Dim rng As Range
　Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Resize(, 3)
　Application.ScreenUpdating = False
　With rng.Columns(3).Cells.Offset(, 1)
　　.Insert xlShiftToRight
　　.Offset(, -1).Formula = "=ISERROR(FIND(""" & sWORD & """,RC[-1]))"
　End With
　rng.Resize(, 4).Sort Key1:=rng.Cells(1, 4), _
　Order1:=xlDescending, _
　Header:=xlYes
　rng.Resize(, 4).Columns(4).Delete
　Application.ScreenUpdating = True
End Sub

お礼

ご回答ありがとうございます。

回答No.3

tom04

こんばんは！
すでに回答は出ていますので、参考程度で・・・

一例です。
「特定の文字」が変わってもいいように、INPUTBOXを使ってみました。

Sub test()
Dim i As Long
Dim str As String
str = InputBox("特定文字を入力してください。")
For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 3) Like "*" & str & "*" Then
Range(Cells(i, 1), Cells(i, 3)).Cut
Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
Next i
For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
If Cells(i, 1) = "" Then
Rows(i).Delete (xlUp)
End If
Next i
End Sub

こんな感じではどうでしょうか？m(__)m

お礼

ご回答ありがとうございます。

回答No.1

hananoppo

次のようなマクロでよいと思います。

Sub DataSort()
Dim PasteRow As Long
Dim LastRow As Long
Dim MatchCell As Range
Dim CutRow As Long

Application.ScreenUpdating = False
PasteRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For LastRow = PasteRow - 1 To 3 Step -1
Set MatchCell = Range("C3:C" & LastRow).Find(What:="和", After:=Range("C" & LastRow), LookAt:=xlPart)
If MatchCell Is Nothing Then
Exit For
Else
CutRow = MatchCell.Row
Rows(CutRow).Cut Rows(PasteRow)
Rows(CutRow).Delete
End If
Next LastRow
Application.ScreenUpdating = True
End Sub

このマクロはExcel 2000で作成しました。また、並び替え後も元の並び順が保たれるようにしています。

お礼

ご回答ありがとうございます。