| |
エクセル初心者 さん、こんにちわ。
>表の内容は
>Ａ〜Ｉ列まではお客様データ そしてＪ列に住所が 「何々県何々区何々町・・・」といった感じにあります。
Ｃ列でチェック→Ｊ列でチェックにしました。
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
'１行目は見出し、J列でソート
r1.EntireRow.Sort Key1:=.Cells(1, 10), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke
'
Do
RR1 = 2: RR2 = 2
'J列が住所（都道府県が必ず入っていること）
If .Cells(RR1, 10).Value = "" Then Exit Do
Do
'左３文字で比較する
If Left(.Cells(RR1, 10).Value, 3) <> _
Left(.Cells(RR2 + 1, 10).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, 10).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
If .Parent.Worksheets.Count = 1 Then
MsgBox "J2セルを確認", vbExclamation, "振り分け失敗？"
Else
Application.DisplayAlerts = False
.Delete '元データをコピーしたシートを削除
Application.DisplayAlerts = True
End If
End With
Set ws2 = Nothing: Set ws1 = Nothing
End Sub
シートを削除する際にエラーになったのは、振り分けに失敗した状態で（２行目が空欄だったりとか）、新しいシートに振り分けできていないのに、元のシートを削除しようとしたからです。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 05/8/8(月) 12:55 -
