Excel VBA質問箱 IV

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

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


54132 / 76738 ←次へ | 前へ→

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

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

>表の内容は
>A〜I列まではお客様データ そしてJ列に住所が 「何々県何々区何々町・・・」といった感じにあります。

C列でチェック→J列でチェックにしました。
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行目は見出し、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
      '左3文字で比較する
      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

シートを削除する際にエラーになったのは、振り分けに失敗した状態で(2行目が空欄だったりとか)、新しいシートに振り分けできていないのに、元のシートを削除しようとしたからです。

0 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 発言

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