Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


54131 / 76732 ←次へ | 前へ→

【27402】Re:住所別に振分・・・
回答  りん E-MAIL  - 05/8/8(月) 12:55 -

引用なし
パスワード
   エクセル初心者 さん、こんにちわ。

・1行目は見出し
・C列に住所が都道府県から入っている
・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
   '1行目は見出し、C列でソート
   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
      '左3文字で比較する
      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

こんな感じです。
動作としては、
 連番をふる
 都道府県列でソート(ふりがなは使わない)

その後、 

 連続範囲を判定して新しいシートに振り分ける
 元の並びにソート
 ソートキーを削除
を繰返しています。

2 hits

【27396】住所別に振分・・・ エクセル初心者 05/8/8(月) 9:23 質問
【27398】Re:住所別に振分・・・ ちくたく 05/8/8(月) 10:33 回答
【27399】Re:住所別に振分・・・ Jaka 05/8/8(月) 11:37 回答
【27402】Re:住所別に振分・・・ りん 05/8/8(月) 12:55 回答
【27404】Re:住所別に振分・・・ エクセル初心者 05/8/8(月) 13:13 質問
【27407】Re:住所別に振分・・・ りん 05/8/8(月) 14:33 回答
【27405】Re:住所別に振分・・・ エクセル初心者 05/8/8(月) 13:26 発言

54131 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free