| |
エクセル初心者 さん、こんにちわ。
・１行目は見出し
・Ｃ列に住所が都道府県から入っている
・IV列まで使われていない
アクティブシートの内容が、上記条件を満たすとして。
Sub TEST()
Dim Rmax As Long, Cmax As Long, RR1 As Long, RR2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim r1 As Range
'
ActiveWorkbook.ActiveSheet.Copy '表示しているシートを新しいブックにコピー
Set ws1 = ActiveWorkbook.ActiveSheet 'セット
With ws1.UsedRange
Rmax = .Cells(.Count).Row
Cmax = .Cells(.Count).Column
End With
With ws1
.Cells(1, Cmax + 1).Value = 1
.Cells(2, Cmax + 1).Value = 2
'連番をふる
Set r1 = .Range(.Cells(1, Cmax + 1), .Cells(Rmax, Cmax + 1))
.Range(.Cells(1, Cmax + 1), .Cells(2, Cmax + 1)).AutoFill _
Destination:=r1
'１行目は見出し、Ｃ列でソート
r1.EntireRow.Sort Key1:=.Range("C1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke
'
Do
RR1 = 2: RR2 = 2
'C列が住所（都道府県が必ず入っていること）
If .Cells(RR1, 3).Value = "" Then Exit Do
Do
'左３文字で比較する
If Left(.Cells(RR1, 3).Value, 3) <> _
Left(.Cells(RR2 + 1, 3).Value, 3) Then Exit Do
RR2 = RR2 + 1
Loop
'
With .Parent
Set ws2 = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With
'
ws2.Name = Left(.Cells(RR1, 3).Value, 3)
'
.Rows(1).Copy
ws2.Cells(1, 1).PasteSpecial Paste:=-4104
ws2.Cells(1, 1).PasteSpecial Paste:=8 '列幅
With .Range(.Cells(RR1, 1), .Cells(RR2, 1)).EntireRow
.Cut Destination:=ws2.Cells(2, 1)
.Delete
End With
'元の並びに戻す
With ws2
.UsedRange.Sort Key1:=.Cells(1, Cmax + 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke
.Columns(Cmax + 1).Delete 'ソートキー削除
End With
Application.CutCopyMode = False
Loop
Application.DisplayAlerts = False
.Delete '元データをコピーしたシートを削除
Application.DisplayAlerts = True
End With
Set ws2 = Nothing: Set ws1 = Nothing
End Sub
こんな感じです。
動作としては、
連番をふる
都道府県列でソート（ふりがなは使わない）
その後、
連続範囲を判定して新しいシートに振り分ける
元の並びにソート
ソートキーを削除
を繰返しています。
|
|
りん
- 05/8/8(月) 12:55 -
