エクセル ＶＢＡ

質問

Sheet1（データベース）のＡ列に会社名（約３０社）
Ｂ列に管理番号0001～9999の番号
Ｃ列に取扱い品名（同じ会社名で複数あります）
Ｄ列以降はその他の詳細（列は不規則）があります。

Sheet1をもとに会社名ごとのシートを作成し、管理番号順に並べ替えをしたいのですがうまくいきません。
どなたかお知恵をお貸し下さい。

回答No.1

kmetu · ベストアンサー

Sub test()

With ActiveSheet
.Columns("B:B").Select

.Range("A1:D" & .Range("A" & Rows.Count).End(xlUp).Row).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
For Each mRange In .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mRange.Value
Rows(mRange.Row).Copy
Worksheets(mRange.Value).Rows(1).PasteSpecial
Next
End With

End Sub

でいかがですか

お礼

返答ありがとうございます。
早速実行してみましが・・・
.Range("A1:D" & .Range("A" & Rows.Count).End(xlUp).Row).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
この部分で
実行時エラー 1004
この操作には、同じサイズの結合セルが必要です。
と、なります。

やり方は色々とあると思うのですが、
imogasiさんのおっしゃる通り、もっと悩んで、考えて、勉強してみます。
ありがとうございました。

回答No.5

kmetu

No4です

質問者さんのパターンだとこちらのほうが分かりやすいかもですね

Do
中略
Loop Until ActiveSheet.Range(場所).Row = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

A列最後の行とアクティブな行が一致するまで繰り返す。

お礼

細かいところまでありがとうございました。
もう少し自分で勉強してみます。

回答No.4

kmetu

> この部分で
> 実行時エラー 1004
> この操作には、同じサイズの結合セルが必要です。
> と、なります。

具体的な状態がわからないのでこの部分の回答はできませんが
並び替えは出来たみたいですね。

> これだと会社名の数だけ同じコードを作らないといけなくて・・・'

ループを利用すればいかがですか
イメージとしては以下のようになります
イメージですので未検証ですから細かいところは修正してください。

Sub test()

移動 = 0
場所 = Range("A5").Offset(移動).Address

'A列の最後のデータがある行分ループする
For i = 5 To ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

Range(場所).Select

Do Until 値 <> Range(場所).Offset(移動).Value
移動 = 移動 + 1
Range("A5").Resize(移動, 27).Select
Loop
'↑最初の会社名から会社名が変わるセルを検索'
Selection.Copy
Sheets.Add
ActiveSheet.Name = 値
Range("A5").Select
Selection.PasteSpecial
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'列幅と行数も同じにコピーしたいので↑のようなコードに・・・'
'行数は取得してコピー先シートに活かすまではわかりませんでした'
元シート.Select

値 = Range("A5").Offset(移動).Value
場所 = Range("A5").Offset(移動).Address
移動 = 0

Next i

End Sub

お礼

返答ありがとうございます。
試してみましたが、うまく起動しませんでした＞＜

いまいち For Next の構文が理解できません・・・
もっと勉強して出直してきます。

回答No.3

cistronezk

一時的な作業ならVBA書くまでもありません。
（１）Ctrl+*で範囲を選択して管理番号順に並べ替え
（２）フィルタを掛け、会社名でフィルタ。Ctrl+*で範囲を選択してコピー。
（３）新シートを挿入して貼り付け。不要な列を削除。シート名を変更。
（４）２と３を会社名毎にくりかえす。
約３０社なので１時間程度で終わりそうです。

あるいは通常業務としての作業なら、上記の手順をマクロで記録して手直しすればいいでしょう。

お礼

返答ありがとうございます。
一時的な作業ではなく、会社名や取扱い品名等が頻繁に変わる為、
マクロで出来ないか考えてます。

回答No.2

imogasi

処理ロジックはどう考えた？
それも書いてなくて、考えたのかどうかもわからない。
この訓練をしないと、VBAの文法やメソッド・プロパティ・関数の勉強をしてもだめ。ロジックの勉強は、自分で考え抜いて、（他人のものや、自分の過去のものと比べよいものを学ぶ）経験をつむしかない。
うまく行かないといってコードでも作って見たのカナ。
形の上では丸投げ質問。
ーー
私が思う、一番簡単なのは
元シートを保存のためコピー（以下コピー先シートで考える）
（１）会社名＋管理番号でソート（ー＞マクロの記録で判る）
（２）上の行から順次For　Nextで各行データを処理し、会社名が変わった行を捉える（直前行の会社名と（IF文で）比べるとよい）。
その前に、会社名が変わった行を記録する１つの変数を儲け、そこに記録しておく。一前だけの記録でよい。
（最初はデータ開始行の第２行目や、第３行目の２や３をセット
する）
（３）前の、会社名が変わった行（記録した行番号）から、「今回会社名の変わった行」ー１（直前ぎょうまで）をコピーして、別シートのA2（データの最初のセル）などを起点にに貼り付ける。
（４）前述の「会社名が変わった行を記録する１つの変数」に今回の会社名が変わった行数をセットする（置き換える）。
（５）（２）－（４）を繰り返す。
ーー
会社名が変わったとき、新しいシートを追加し、新しいシート名を設定するコードを勉強のこと。
Googleで「VBA Add.Name」で照会のこと。
ーー
シートがたくさんできるが、それを特定するコードの書き方を勉強すること。

お礼

返答ありがとうございます。
imogasiさんのおっしゃる通りです＞＜
色々と考えた挙句コードが組めず、質問の丸投げをしてしまいました。
反省し下記のようなコードを考えてみました。

Sub 並べ替えとシート作成()

Dim 元シート As Worksheet
Dim 移動 As Long
Dim 値 As String

Set 元シート = Sheets("データベース")
移動 = 0
値 = Range("A5").Value
'正確にはA4から見出しの入った表になってます'
Range("A4").CurrentRegion.Select
Selection.Sort Key1:=Range("A5"), Order1:=xlAscending, Key2:=Range("B5"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
'↑　これで並べ替えは出来ました'
Range("A5").Select

Do Until 値 <> Range("A5").Offset(移動).Value
移動 = 移動 + 1
Range("A5").Resize(移動, 27).Select
Loop
'↑最初の会社名から会社名が変わるセルを検索'
Selection.Copy
Sheets.Add
ActiveSheet.Name = 値
Range("A5").Select
Selection.PasteSpecial
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'列幅と行数も同じにコピーしたいので↑のようなコードに・・・'
'行数は取得してコピー先シートに活かすまではわかりませんでした'
元シート.Select

値 = Range("A5").Offset(移動).Value
場所 = Range("A5").Offset(移動).Address
移動 = 0

Do Until 値 <> Range(場所).Offset(移動).Value
移動 = 移動 + 1
Range(場所).Resize(移動, 27).Select
Loop

Selection.Copy
Sheets.Add
ActiveSheet.Name = 値
Selection.PasteSpecial
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'これだと会社名の数だけ同じコードを作らないといけなくて・・・'

End Sub