Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

7783 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【36795】項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 2:50

【36805】Re:項目に応じたシートの振分け Jaka 06/4/14(金) 12:18

【36811】補足 Jaka 06/4/14(金) 13:56

【36822】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 17:36

【36810】Re:項目に応じたシートの振分け Kein 06/4/14(金) 13:42

【36826】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 18:24

【36827】Re:項目に応じたシートの振分け Kein 06/4/14(金) 18:31

【36830】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 19:09

【36832】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 21:04

【36837】Re:項目に応じたシートの振分け Kein 06/4/14(金) 22:03

【36840】Re:項目に応じたシートの振分け 初心者のトトロ 06/4/14(金) 22:29

【36861】項目に応じたシートの振分け続き 初心者のトトロ 06/4/16(日) 23:37

【36870】Re:項目に応じたシートの振分け続き Kein 06/4/17(月) 10:35

【36908】Re:項目に応じたシートの振分け続き 初心者のトトロ 06/4/17(月) 21:52

【36910】Re:項目に応じたシートの振分け続き Kein 06/4/17(月) 22:26

【36914】Re:項目に応じたシートの振分け続き 初心者のトトロ 06/4/18(火) 0:05


	【36795】項目に応じたシートの振分け

初心者のトトロ - 06/4/14(金) 2:50 -


	引用なし

	パスワード

はじめまして。いろいろな物を参考にして試してみたのですがうまくいきませんでした。
独学で始めた超初心者ですがよろしくお願いします。

OS:WINDOWS98SE EXCEL2000を使用しています。

下記のCSVデータをあらかじめ用意されたエクセルファイルのsheet1に取り込んで、同じファイルで、同様にあらかじめ準備されたシート名(1000、1500、2000)に振分けたいのですがどのようにしたらよいのでしょうか?

＊＊＊＊＊＊＊＊＊＊＊振分け前データ＊＊＊＊＊＊＊＊＊＊
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1500,xx,xx,xx　　　　　　
2005/10/10,AAAAA,2000,xx,xx,xx
2005/10/10,AAAAA,2000,xx,xx,xx
　　　　　　　　　↑
　　　　　　　　　ここの項目ごとに振り分けたいです。1000、1500、2000
　　　　　　　　　の行数はそれぞれまちまちです。

＊＊＊＊＊＊＊＊＊＊＊振分け後データ＊＊＊＊＊＊＊＊＊＊＊
シート1000に
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1000,xx,xx,xx

シート1500に
2005/10/10,AAAAA,1500,xx,xx,xx　　　　　　

シート2000に
2005/10/10,AAAAA,2000,xx,xx,xx
2005/10/10,AAAAA,2000,xx,xx,xx

という具合です。

よろしくお願いします。


	【36805】Re:項目に応じたシートの振分け

Jaka - 06/4/14(金) 12:18 -


	引用なし

	パスワード

マクロより手作業の方が速そうな気がします。

Csvファイルを開いて、
B1に
=MID(A1,18,4)
１度別のセルを選択して、B1を選択しなおす
B1セルの右下角にポインタを当て、ポインタが＋になった所でＷクリック。
Ｂ列に1000とか2000とか出るから。
Ｂ列をキーにしてソート。

１行挿入して、Ｂ1に適当な文字を入れて、Ｂ列をオートフィルタ。
1000、2000、3000を抽出後、Ａ列をコピーして好きなシートに張り付ける。
ＣＳＶファイルは保存しないで、そのまま閉じればいいです。


	【36810】Re:項目に応じたシートの振分け

Kein - 06/4/14(金) 13:42 -


	引用なし

	パスワード

Sub シート振り分け()
　 Dim MyF As String, Buf As String, Sn As String
　 Dim WS As Worksheet
　 Dim Ary As Variant
　
　 With Application
　　　MyF = .GetOpenFilename("CSVファイル(*.csv),*.csv")
　　　If MyF = "False" Then Exit Sub
　　　.ScreenUpdating = False
　 End If
　 For Each WS In Sheets(Array("Sheet1", "1000", "1500", "2000"))
　　　WS.Cells.ClearContents
　 Next
　 Open MyF For Input Access Read As #1
　 Do Until EOF(1)
　　　Line Input #1, Buf
　　　Ary = Split(Buf, ",")
　　　Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1) _
　　　.Resize(, UBound(Ary) + 1).Value = Ary
　　　Select Case Ary(2)
　　　　 Case 1000, 1500, 2000
　　　　　　Sn = CStr(Ary(2))
　　　　　　Sheets(Sn).Range("A65536").End(xlUp).Offset(1) _
　　　　　　.Resize(, UBound(Ary) + 1).Value = Ary
　　　End Select
　　　Erase Ary
　 Loop
　 Close #1
　 Application.ScreenUpDating = True
End Sub


	【36811】補足

Jaka - 06/4/14(金) 13:56 -


	引用なし

	パスワード

オートフィルタをかける直前に計算方法を手動にしてください。
自動計算のままだと抽出と解除に時間がかかリます。
オートフィルタの抽出や解除時に一々再計算されるので...。


	【36822】Re:項目に応じたシートの振分け

初心者のトトロ - 06/4/14(金) 17:36 -


	引用なし

	パスワード

早速のお返事ありがとうございます。
ずぼらな自分なのでマクロ化したかったのですが、参考になりました。


	【36826】Re:項目に応じたシートの振分け

初心者のトトロ - 06/4/14(金) 18:24 -


	引用なし

	パスワード

▼Kein さん：
出来ました。ありがとうございます。

ただこちらの都合で、1000,1500,2000....4000
と７つの項目に分ける場合が出てきたのですがどうしたらよいでようか？
教えていただいたのを自分なりに手を加えても分かりませんでしたの教えてください。


	【36827】Re:項目に応じたシートの振分け

Kein - 06/4/14(金) 18:31 -


	引用なし

	パスワード

どこが難しいのでしょーか ?

Sub シート振り分け2()
　 Dim MyF As String, Buf As String, Sn As String
　 Dim Ary As Variant
　 Dim i As Long
　
　 With Application
　　　MyF = .GetOpenFilename("CSVファイル(*.csv),*.csv")
　　　If MyF = "False" Then Exit Sub
　　　.ScreenUpdating = False
　 End If
　 Sheets("Sheet1").Cells.ClearContents
　 For i = 1500 To 4000 Step 500
　　　Worksheets(CStr(i)).Cells.ClearContents
　 Next i
　 Open MyF For Input Access Read As #1
　 Do Until EOF(1)
　　　Line Input #1, Buf
　　　Ary = Split(Buf, ",")
　　　Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1) _
　　　.Resize(, UBound(Ary) + 1).Value = Ary
　　　Select Case Ary(2)
　　　　 Case 1000, 1500, 2000, 2500, 3000, 3500, 4000
　　　　　　Sn = CStr(Ary(2))
　　　　　　Sheets(Sn).Range("A65536").End(xlUp).Offset(1) _
　　　　　　.Resize(, UBound(Ary) + 1).Value = Ary
　　　End Select
　　　Erase Ary
　 Loop
　 Close #1
　 Application.ScreenUpDating = True
End Sub


	【36830】Re:項目に応じたシートの振分け

初心者のトトロ - 06/4/14(金) 19:09 -


	引用なし

	パスワード

▼Kein さん：

大変失礼しました。
なんの問題もなかったです。

自分のCSVの表が間違ってましたので、問題は解決しました。

とても助かりました。ありがとうございます。


	【36832】Re:項目に応じたシートの振分け

初心者のトトロ - 06/4/14(金) 21:04 -


	引用なし

	パスワード

▼Kein さん：
度々質問して申し訳ないのですが、
CSVのリストで、L列にある場合の処理を教えてください。

・・・・・・・・・Ｌ　・・・・・・・
2005/10/10,,,,,,AAAAA,1000,xx,xx,xx
2005/10/10,,,,,,AAAAA,1000,xx,xx,xx
2005/10/10,,,,,,AAAAA,1000,xx,xx,xx
2005/10/10,,,,,,AAAAA,1500,xx,xx,xx　　　　　　
2005/10/10,,,,,,AAAAA,2000,xx,xx,xx
2005/10/10,,,,,,AAAAA,2000,xx,xx,xx
　　　　　　　　　↑
　　　　　　　　　ここの項目ごとに振り分けたいです。1000、1500、2000
　　　　　　　　　の行数はそれぞれまちまちです。


	【36837】Re:項目に応じたシートの振分け

Kein - 06/4/14(金) 22:03 -


	引用なし

	パスワード

>Ary = Split(Buf, ",")
として作られた配列は、Indexの下限が 0 になります。従って C列の値は Ary(2)
で取得できるわけです。この順序でいくと L列(シート上で12列目)は、Index が 11
になるはずだから、Ary(2) → Ary(11) と変更すれば良いのです。
(先のコード中には2ヶ所あります。)


	【36840】Re:項目に応じたシートの振分け

初心者のトトロ - 06/4/14(金) 22:29 -


	引用なし

	パスワード

▼Kein さん：
ご親切にありがとうございます。
勉強になりました。


	【36861】項目に応じたシートの振分け続き

初心者のトトロ - 06/4/16(日) 23:37 -


	引用なし

	パスワード

以前に似たような質問をしましたが、
あらかじめSheet1に以下のような表があります。
これをL列の項目に応じて各シート（1000、1200、2000,2200）に振り分けたいのですどうしたらよいでしょうか？
今の自分のスキルではうまくいきません。

OS:WINDOWS98SE EXCEL2000を使用しています。

＊＊＊＊＊＊＊＊＊＊＊振分け前データ＊＊＊＊＊＊＊＊＊＊
　　　・・・・・・・・・・・・・・ L ・・・・・・
2005/10/10,,,,AAAAA,1000,xx,xx,xx
2005/10/10,,,,AAAAA,1000,xx,xx,xx
2005/10/10,,,,AAAAA,1000,xx,xx,xx
2005/10/10,,,,AAAAA,1200,xx,xx,xx　　　　　　
2005/10/10,,,,AAAAA,2000,xx,xx,xx
2005/10/10,,,,AAAAA,2000,xx,xx,xx
2005/10/10,,,,AAAAA,2200,xx,xx,xx
　　　　　　　　　　　　　　↑
　　　　　　　　　　ここの項目ごとに振り分けたいです。1000、1200､2000､2200
　　　　　　　　　　の行数はそれぞれまちまちです。

＊＊＊＊＊＊＊＊＊＊＊振分け後データ＊＊＊＊＊＊＊＊＊＊＊
シート1000に
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1000,xx,xx,xx
2005/10/10,AAAAA,1000,xx,xx,xx

シート1200に
2005/10/10,AAAAA,1500,xx,xx,xx　　　　　　

シート2000に
2005/10/10,AAAAA,2000,xx,xx,xx
2005/10/10,AAAAA,2000,xx,xx,xx

シート2200に
2005/10/10,AAAAA,2200,xx,xx,xx

という具合です。
よろしくお願いします。


	【36870】Re:項目に応じたシートの振分け続き

Kein - 06/4/17(月) 10:35 -


	引用なし

	パスワード

Sub シート振り分け()
　 Dim Sh As Worksheet, Psh As Worksheet
　 Dim Snm As String
　 Dim MyR As Range, C As Range
　
　 Set Sh = Worksheets("Sheet1")
　 Application.ScreenUpdating = False
　 Sh.Range("A1").CurrentRegion.Sort Key1:=Sh.Columns(12), _
　 Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortColumns
　 Sh.Range("A1").Subtotal 12, xlCount, Array(2)
　 Set MyR = Range("A1", Range("A65536").End(xlUp)) _
　 .SpecialCells(2)
　 For Each C In MyR.Areas
　　　Snm = CStr(C.Range("L1").Value)
　　　On Error Resume Next
　　　Set Psh = Worksheets(Snm)
　　　If Err.Number <> 0 Then
　　　　 Set Psh = Worksheets.Add(Before:=Worksheets(1))
　　　　 Psh.Name = Snm: Err.Clear
　　　End If
　　　On Error GoTo 0　
　　　C.EntireRow.Copy
　　　Psh.Range("A1").PasteSpecial xlPasteValues
　　　Application.CutCopyMode = False: Set Psh = Nothing
　 Next
　 Sh.Activate: Sh.Cells.RemoveSubtotal
　 Application.ScreenUpdating = True
　 Set MyR = Nothing: Set Sh = Nothing
End Sub


	【36908】Re:項目に応じたシートの振分け続き

初心者のトトロ - 06/4/17(月) 21:52 -


	引用なし

	パスワード

▼Kein さん：
何時も親切にありがとうございます。
それでまた二度、三度手間で申し訳ないのですが、私の説明不足で見出し行一行含んでいます。それでこれを含んでいるソートが出来ないというような警告が出てきて、一度そこで「OK」を押さないといけないのですがこれを省くにはどうしたらよいでしょうか？
あと一週間ごとに累積で各シートに追加していきたいのですが、
Psh.Range("A2").PasteSpecial xlPasteValues
のところを
Psh.Range("A2").End(xlDown).Offset(1).PasteSpecial xlPasteValues
とするだけではダメなのでしょうか？
それとも他にも何か必要でしょうか？

あまりの知識不足で自分がしたいことを正確に説明できずに質問ばかりして済みませんがよろしくお願いします。


	【36910】Re:項目に応じたシートの振分け続き

Kein - 06/4/17(月) 22:26 -


	引用なし

	パスワード

>一週間ごとに累積で各シートに追加
それはつまり、Sheet1 にどんどんデータが追加されていく、ということですね ?
その場合、過去に転記したデータもSheet1に残っている、という前提になるので
いったん各シートのデータを消してから、過去データも含めてあらためて転記します。
そして1行目は項目行である、という条件も加味して・・

Sub シート振り分け2()
　 Dim Sh As Worksheet, Psh As Worksheet
　 Dim Snm As String
　 Dim MyR As Range, C As Range
　
　 Set Sh = Worksheets("Sheet1")
　 Application.ScreenUpdating = False
　 Sh.Range("A1").CurrentRegion.Sort Key1:=Sh.Range("L1"), _
　 Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
　 Sh.Range("A1").Subtotal 12, xlCount, Array(2)
　 Set MyR = Range("A2", Range("A65536").End(xlUp)) _
　 .SpecialCells(2)
　 For Each C In MyR.Areas
　　　Snm = CStr(C.Range("L1").Value)
　　　On Error Resume Next
　　　Set Psh = Worksheets(Snm)
　　　If Err.Number <> 0 Then
　　　　 Set Psh = Worksheets.Add(Before:=Worksheets(1))
　　　　 Psh.Name = Snm: Err.Clear
　　　Else
　　　　 Psh.Cells.ClearContents
　　　End If
　　　On Error GoTo 0
　　　Sh.Rows(1).Copy Psh.Range("A1")
　　　C.EntireRow.Copy
　　　Psh.Range("A2").PasteSpecial xlPasteValues
　　　Application.CutCopyMode = False: Set Psh = Nothing
　 Next
　 Sh.Activate: Sh.Cells.RemoveSubtotal
　 Application.ScreenUpdating = True
　 Set MyR = Nothing: Set Sh = Nothing
End Sub

ということになります。どこが変化したのか、よく見て理解して下さい。


	【36914】Re:項目に応じたシートの振分け続き

初心者のトトロ - 06/4/18(火) 0:05 -


	引用なし

	パスワード

▼Kein さん：
早速のお返事ありがとうございます。

自分が作ろうとしていたものよりこっちのほうがよっぽどいいですね。
これで満足のいく作業が出来ます。
この先また自分が作業を進めていく上で問題が発生すると思います（間違いない）ので、自分なりに努力はしますが、そのときはまたお世話になると思いますのでよろしくお願いします。
どうもありがとうございました。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

7783 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free