Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
12107 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【12095】Caseに続く部分を自動的に持ってこれるか？ まだ初心者 04/3/23(火) 21:18 質問
【12122】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/24(水) 14:28 回答
【12199】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/26(金) 15:02 質問
【12200】Re:Caseに続く部分を自動的に持ってこれる... つん 04/3/26(金) 15:11 発言
【12215】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/26(金) 17:41 回答
【12216】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/26(金) 19:14 質問
【12234】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/27(土) 14:52 回答
【12263】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/29(月) 10:25 質問
【12269】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/29(月) 11:54 回答
【12275】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/29(月) 13:49 質問
【12276】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/29(月) 14:00 回答
【12277】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/29(月) 15:28 質問
【12281】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/29(月) 16:36 回答
【12299】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/30(火) 8:42 質問
【12305】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/30(火) 10:52 発言
【12306】Re:Caseに続く部分を自動的に持ってこれる... Asaki 04/3/30(火) 11:04 回答
【12316】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/30(火) 14:41 質問
【12318】Re:Caseに続く部分を自動的に持ってこれる... こうちゃん 04/3/30(火) 15:23 発言
【12320】Re:Caseに続く部分を自動的に持ってこれる... まだ初心者 04/3/30(火) 16:29 質問
【12322】もう少しわかるようにお願いします。 こうちゃん 04/3/30(火) 16:42 発言
【12323】深くなったのでこちらに返信お願いします。 こうちゃん 04/3/30(火) 16:44 発言
【12324】Re:深くなったのでこちらに返信お願いしま... Asaki 04/3/30(火) 16:56 回答
【12325】Re:深くなったのでこちらに返信お願いしま... まだ初心者 04/3/30(火) 17:55 質問
【12327】Re:深くなったのでこちらに返信お願いしま... Asaki 04/3/30(火) 20:04 回答
【12337】Re:深くなったのでこちらに返信お願いしま... まだ初心者 04/3/31(水) 10:17 お礼
【12338】おつかれさまでした＾＾ こうちゃん 04/3/31(水) 10:45 発言
【12339】Re:おつかれさまでした＾＾ Asaki 04/3/31(水) 10:58 発言
【12095】Caseに続く部分を自動的に持ってこれるか...
質問  まだ初心者  - 04/3/23(火) 21:18 -
引用なし
パスワード
   こんにちは。
営業所の混在している一覧を、営業所ごとのシートに分けているところです。

Sub AAA()
Dim I, A, B
A = 2
B = 2
With Sheets("一覧")
For I = 2 To .Range("A65535").End(xlUp).Row
Select Case .Cells(I, 10).Value
Case "川崎営"
Sheets("a").Cells(A, 1).Value = Cells(I, 9).Value
Sheets("a").Cells(A, 2).Value = Cells(I, 10).Value
A = A + 1
Case "港北営"
Sheets("b").Cells(B, 1).Value = Cells(I, 9).Value
Sheets("b").Cells(B, 2).Value = Cells(I, 10).Value
B = B + 1
End Select
Next
End With
End Sub

川崎営や港北営のほかにも営業所があり､現在､別BOOKにリスト化してあります｡
そのリストにある全営業所をﾌﾟﾛｸﾞﾗﾑにCase "○○営"として
自動的に持って来ることは可能でしょうか？
【12122】Re:Caseに続く部分を自動的に持ってこれ...
回答  こうちゃん E-MAIL  - 04/3/24(水) 14:28 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>営業所の混在している一覧を、営業所ごとのシートに分けているところです。
>
>Sub AAA()
>Dim I, A, B
>A = 2
>B = 2
>With Sheets("一覧")
>For I = 2 To .Range("A65535").End(xlUp).Row
>Select Case .Cells(I, 10).Value
>Case "川崎営"
>Sheets("a").Cells(A, 1).Value = Cells(I, 9).Value
>Sheets("a").Cells(A, 2).Value = Cells(I, 10).Value
>A = A + 1
>Case "港北営"
>Sheets("b").Cells(B, 1).Value = Cells(I, 9).Value
>Sheets("b").Cells(B, 2).Value = Cells(I, 10).Value
>B = B + 1
>End Select
>Next
>End With
>End Sub
>
>川崎営や港北営のほかにも営業所があり､現在､別BOOKにリスト化してあります｡
>そのリストにある全営業所をﾌﾟﾛｸﾞﾗﾑにCase "○○営"として
>自動的に持って来ることは可能でしょうか？

可能ではあると思いますが、失礼ながら「まだ初心者」の方には敷居が高いのではないでしょうか？
それよりも別BOOKのリストから動的に判別してコピーするようにしたらいかがでしょう？
例では川崎営はA列に、港北営はB列にコピーしているようですが、営業所ごとにどのシートのどの列にコピーするかの規則はあるのですか？
もし、コピー先の列が同じならば、Cells(I, 10).Valueに書かれている営業所名と各シート名を同じにしておいて、そこにコピーするようにしたらいかがでしょう。
例：シート2を「川崎営」に、シート3を「港北営」にしておいて、
Sheets(Cells(I, 10).Value).Cells(A, 1)にコピーするとか・・
【12199】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/26(金) 15:02 -
引用なし
パスワード
   ▼こうちゃん さん：

>可能ではあると思いますが、
初心者ながらなんとかここまで書きました。

Sub test()
Dim n, i, A
A = 2
Dim d As Characters
Dim ws1, ws2
Set ws1 = Worksheets("一覧")
Set ws2 = Worksheets("全営業所")
For n = 1 To ws2.Cells.Range("A600").End(xlUp).Row
Set d = ws2.Cells(n, 1).Value
For i = 2 To ws1.Range("A65535").End(xlUp).Row
Select Case ws1.Cells(i, 10).Value
Case d
Sheets(Cells(i, 10)).Cells(A, 1).Value = Cells(i, 9).Value
Sheets(Cells(i, 10)).Cells(A, 2).Value = Cells(i, 10).Value
A = A + 1
End Select
Next i
Next n
End Sub

11行目で「ｵﾌﾞｼﾞｪｸﾄが必要です」というﾒｯｾ-ｼﾞが出てしまいます。
どこがいけないのかご指摘いただけませんでしょうか。
【12200】Re:Caseに続く部分を自動的に持ってこれ...
発言  つん E-MAIL  - 04/3/26(金) 15:11 -
引用なし
パスワード
   まだ初心者 さん、こんにちは

こうちゃん さん、横から失礼します〜
私もまだまだ初心者ですが、このへんがおかしいかな？と思うところは
ここやろか↓

>Dim d As Characters
>Set d = ws2.Cells(n, 1).Value

セルの値を代入するんだったら、

Dim d As String ←文字列なら
d = ws2.Cells(n, 1).Value

でいいんじゃ・・・

一応、
Dim d As Characters
これで試してみたけど、エラーになりました。

それから、蛇足っぽくなりますが、コードはインデントを付けた方が
断然読みやすくなりますよ。
自分も読みやすいし、こういう場で見て貰うんでも、
やっぱり回答してくれる人が読みやすい方が、レスの付く率も違うかも・・・
【12215】Re:Caseに続く部分を自動的に持ってこれ...
回答  こうちゃん E-MAIL  - 04/3/26(金) 17:41 -
引用なし
パスワード
   つんさん、まだ初心者さん、こんにちは

>こうちゃん さん、横から失礼します〜
いえいえ、フォローありがとうございます。

インデントはつけたほうがいいよね。
つんさん指摘以外も気になる点を直して、とりあえずエラーにはならないところまでなおしてみました。

Sub test()
'変数の型は明示的にしたほうがいいです。
'Dim n, i, A のような指定ではすべてVariant型に、
'Dim n, i, A As Long のような指定ではA以外はVariant型になります。
Dim n As Long
Dim i As Long
Dim A As Integer
Dim d As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("一覧")
Set ws2 = Worksheets("全営業所")

A = 2
'ws2.Cells.Range("A600").End(xlUp).Row の Cells はいりません。
For n = 1 To ws2.Range("A600").End(xlUp).Row
　　d = ws2.Cells(n, 1).Value
　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　'選択肢が1つの場合は、Select CaseよりIf文のほうが可読性がいいですよ。
　　　　If ws1.Cells(i, 10).Value = d Then
　　　　　　Sheets(Cells(i, 10).Value).Cells(A, 1).Value = _
　　　　　　　　　　　 ws1.Cells(i, 9).Value
　　　　　　Sheets(Cells(i, 10).Value).Cells(A, 2).Value = _
　　　　　　　　　　　 ws1.Cells(i, 10).Value
　　　　　　A = A + 1
　　　　End If
　　Next i
Next n

End Sub

ただこのままでは、変数Aの処理に問題があって、意図したものとちがうかもしれません。
＃それが意図したものであったら失礼。
【12216】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/26(金) 19:14 -
引用なし
パスワード
   ▼こうちゃんさん、つんさん、ありがとうございます。

私の意図はこうです。
全部で600ある選択肢をdに代入していきます。
caseごとに、すなわちdの値ごとに、その都度addされたﾜｰｸｼｰﾄにﾃﾞｰﾀを書きこみます。
そして最終的に600枚のｼｰﾄができる、というものです。
ところが、ﾜｰｸｼｰﾄのaddすら出来ていません。
いったいどこを直せばよいのでしょうか。


Sub test()
Dim n As Long
Dim i As Long
Dim A As Integer
Dim d As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'変数bを追加します。
Dim b As Integer

Set ws1 = Worksheets("一覧")
Set ws2 = Worksheets("全営業所")

'変数Aの処理をしました
A = 13
For n = 1 To ws2.Range("A600").End(xlUp).Row
　　d = ws2.Cells(n, 1).Value
　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　'select caseにします。実際は選択肢が600個すなわちdに代入されうる値が_
　　 600種類あるからです。
　　　　Select Case ws1.Cells(i, 10).Value = d
　　　　Case d
　　　　　　'b=1のときのみﾜｰｸｼｰﾄをaddするﾛｼﾞｯｸを追加します。
　　　　　　If b = 1 Then
　　　　　　Worksheets.Add after:=Worksheets(1), Count:=1
　　　　　　b = b + 1
　　　　　　End If
　　　　　　'addしたてのﾜｰｸｼｰﾄに書きこんでいきたいのです。
　　　　　　Sheets(Cells(i, 10).Value).Cells(A, 1).Value=_
　　　　　　　　　　　　　　　　　　 　 ws1.Cells(i, 9).Value
　　　　　　Sheets(Cells(i, 10).Value).Cells(A, 2).Value=_
　　　　　　　　　　　　　　　　　　　 ws1.Cells(i, 10).Value
　　　　　　A = A + 1
　　　　End Select
　　　　b = 1
　　Next i
Next n

End Sub
【12234】Re:Caseに続く部分を自動的に持ってこれ...
回答  こうちゃん  - 04/3/27(土) 14:52 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>私の意図はこうです。
>全部で600ある選択肢をdに代入していきます。
>caseごとに、すなわちdの値ごとに、その都度addされたﾜｰｸｼｰﾄにﾃﾞｰﾀを書きこみます。
>そして最終的に600枚のｼｰﾄができる、というものです。
>ところが、ﾜｰｸｼｰﾄのaddすら出来ていません。
>いったいどこを直せばよいのでしょうか。

最初からそういう説明が欲しかったですね。
その仕様だと、全営業所シートはいらないと思います。
ループも１つでよさそうです。

こんな感じでいかがでしょう？
＃少し冗長ですがわかりやすさ優先ということで(^^;)
＃変数はある程度意味を持たせたほうが可読性があがります。
A >> NewRow　d >> BranchName　とかね。

Sub test()
　　Dim i As Long
　　Dim A As Integer
　　Dim d As String
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim wsFlg As Boolean
　　
　　Set ws1 = Worksheets("一覧")
　　
　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　d = ws1.Cells(i, 9).Value
　　　　wsFlg = False
　　　　For Each ws2 In Worksheets
　　　　　　If ws2.Name = d Then
　　　　　　　　wsFlg = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If Not wsFlg Then
　　　　　　Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = d
　　　　End If
　　　　
　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row
　　　　Worksheets(d).Cells(A, 1).Value = _
　　　　　　　　　　　　　　ws1.Cells(i, 9).Value
　　　　Worksheets(d).Cells(A, 2).Value = _
　　　　　　　　　　　　　　ws1.Cells(i, 10).Value
　　Next

End Sub
【12263】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/29(月) 10:25 -
引用なし
パスワード
   ▼こうちゃん さん：
週末に考えましたがまだ問題が解決できません。
dの値ごとのｼｰﾄに集約したいのですが
dの数だけｼｰﾄが出きてしまいます。
どうすれば解決できるでしょうか？

　Sub test()
　　Dim i As Long
　　Dim A As Integer
　　Dim d As String
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim wsFlg As Boolean
　
　　Set ws1 = Worksheets("一覧")
　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　d = ws1.Cells(i, 10).Value
　　　　'9でなく10でした。単純間違いです。
　　　　wsFlg = False
　　　　For Each ws2 In Worksheets
　　　　　　If ws2.Name = d Then
　　　　　　　　wsFlg = True
　　　　　　　　Exit For
　　　　　　End If
　　　
　　　　If Not wsFlg Then
　　　' Addでなく書式の入ったｼｰﾄaをｺﾋﾟｰすることにしました。
　　　' Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = d
　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)
　　　 ' Aの処理を直しました。8行目に(i,9)(i,10)を、_
　　　　　13行目以降に(i,4)(i,5)…をいれます。
　　　　A = 13
　　　　End If
　　
　　　 ' A = Worksheets(d).Range("A65536").End(xlUp).Row

　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　A = A + 1
　　　　Next
　　Next
　　End Sub
【12269】Re:Caseに続く部分を自動的に持ってこれ...
回答  こうちゃん E-MAIL  - 04/3/29(月) 11:54 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>週末に考えましたがまだ問題が解決できません。
>dの値ごとのｼｰﾄに集約したいのですが
>dの数だけｼｰﾄが出きてしまいます。
>どうすれば解決できるでしょうか？

前回提示したコードの動作確認はしたのですか？
その結果は？
コードを見ると私の提示したコードがベースになっているようですが、そこまではOKですか？
そのうえでの質問かどうかで、回答も変わります。
まだ初心者さんからもレスポンスがないと回答する側としては、回答しづらいばかりでなく、なかには気分を害する方もありますので（私もすこ〜し(--メ)、です(^^;)）、気をつけてくださいね。

さて、コードですが・・

>　Sub test()
>　　Dim i As Long
>　　Dim A As Integer
>　　Dim d As String
>　　Dim ws1 As Worksheet
>　　Dim ws2 As Worksheet
>　　Dim wsFlg As Boolean
>　
>　　Set ws1 = Worksheets("一覧")
>　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
>　　　　d = ws1.Cells(i, 10).Value
>　　　　'9でなく10でした。単純間違いです。
>　　　　wsFlg = False
>　　　　For Each ws2 In Worksheets
>　　　　　　If ws2.Name = d Then
>　　　　　　　　wsFlg = True
>　　　　　　　　Exit For
>　　　　　　End If
>　　　
>　　　　If Not wsFlg Then
>　　　' Addでなく書式の入ったｼｰﾄaをｺﾋﾟｰすることにしました。
>　　　' Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = d
>　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)

ここでシート名を変更していないようですね？
そのためシートが既定のシート名で追加されます（ここでは"a(3)"とか・・）ので、シート名存在チェックにかからないため、必ずる追加されてしまいます。
ここに、シート名を変数d と同じように変更する処理をいれましょう。

>　　　 ' Aの処理を直しました。8行目に(i,9)(i,10)を、_
>　　　　　13行目以降に(i,4)(i,5)…をいれます。
>　　　　A = 13
Aの初期化をシート作成時に行うと希望の動作にならない場合があるかもしれません。
データの並びがd(営業所名)の順番でならびかえられていればいいのですが、ランダムになっている場合、すでに作成されているシートに書き込む場合、予期しない位置に書き込むことが考えられます。
　　　　 Else
シート作成時以外はすでに13行目以降にかきこまれていますんので、現在の買い込み位置の最大を検索するようにしたらいかがでしょうか・・
　　　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row + 1
>　　　　End If
>
>　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
>　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
>　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
>　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
>　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
>　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
>　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
>　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
>　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
>　　　　A = A + 1
>　　　　Next
>　　Next
>　　End Sub
【12275】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/29(月) 13:49 -
引用なし
パスワード
   ▼こうちゃん さん：
提示いただいたコードがベースで、そこまではOKです。
そのうえでの質問です。

>気分を害する方もありますので
できる限り自分でやってみようと思いました。
申し訳ございませんでした。

　　Sub test()
　　Dim i As Long
　　Dim A As Integer
　　Dim d As String
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim wsFlg As Boolean

　　Set ws1 = Worksheets("一覧")
　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　d = ws1.Cells(i, 10).Value
　
　　　　wsFlg = False
　　　　For Each ws2 In Worksheets
　　　　　　If ws2.Name = d Then
　　　　　　　　wsFlg = True
　　　　　　　　Exit For
　　　　　　End If

　　　　If Not wsFlg Then

　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)

　　　　 'ここで、シート名を変数d と同じように変更する処理を_
　　　　　教えてくださいませんか。

　　　　A = 13

　　　　 Else

　　　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row + 1
　　　　End If

　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　A = A + 1
　　　　Next
　　Next
　　End Sub
【12276】Re:Caseに続く部分を自動的に持ってこれ...
回答  こうちゃん E-MAIL  - 04/3/29(月) 14:00 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>できる限り自分でやってみようと思いました。
>申し訳ございませんでした。
いえいえ、その姿勢はとても大事だと思います。
だだ、次の質問のまえに、そこまでの経緯等を教えていただきたいのです。

>　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)
>
>　　　　 'ここで、シート名を変数d と同じように変更する処理を_
>　　　　　教えてくださいませんか。
Worksheets(Worksheets.Count).Name = d

でいかがでしょうか？
＃Copy が終了した時点で、Worksheets.Countは1つ増えていますので、念のため
【12277】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/29(月) 15:28 -
引用なし
パスワード
   ▼こうちゃん さん：

ﾛｼﾞｯｸをいれましたが「ｼｰﾄ名をほかのｼｰﾄ、VISUAL BASICで参照されるｵﾌﾞｼﾞｪｸﾄﾗｲﾌﾞﾗﾘまたはﾜｰｸｼｰﾄ名と同じ名前に変更することはできません」とでます。
どうすればいいのでしょうか？どうかご教示ください。

　　Sub test()
　　Dim i As Long
　　Dim A As Integer
　　Dim d As String
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim wsFlg As Boolean

　　Set ws1 = Worksheets("一覧")
　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　d = ws1.Cells(i, 10).Value
　
　　　　wsFlg = False
　　　　For Each ws2 In Worksheets
　　　　　　If ws2.Name = d Then
　　　　　　　　wsFlg = True
　　　　　　　　Exit For
　　　　　　End If

　　　　If Not wsFlg Then

　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)
　　　　
　　　　 '↓いれました。
　　　　Worksheets(Worksheets.Count).Name = d
　　　　　　　　
　　　　A = 13

　　　　 Else

　　　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row + 1
　　　　End If

　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　A = A + 1
　　　　Next
　　Next
　　End Sub
【12281】Re:Caseに続く部分を自動的に持ってこれ...
回答  こうちゃん E-MAIL  - 04/3/29(月) 16:36 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>ﾛｼﾞｯｸをいれましたが「ｼｰﾄ名をほかのｼｰﾄ、VISUAL BASICで参照されるｵﾌﾞｼﾞｪｸﾄﾗｲﾌﾞﾗﾘまたはﾜｰｸｼｰﾄ名と同じ名前に変更することはできません」とでます。
>どうすればいいのでしょうか？どうかご教示ください。

Nextの位置がちがいません？
何の処理をしているかを意識して、ブロックごとに字下げをするとロジックがわかりやすくなりますよ。
＃回答者（つんさん、私）のアドバイスも意識していただけるとうれしいな。

>　　Sub test()
>　　Dim i As Long
>　　Dim A As Integer
>　　Dim d As String
>　　Dim ws1 As Worksheet
>　　Dim ws2 As Worksheet
>　　Dim wsFlg As Boolean
>
>　　Set ws1 = Worksheets("一覧")
>　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
>　　　　d = ws1.Cells(i, 10).Value
>　
>　　　　wsFlg = False
'シート全体のなかにシート名が d の値のものがあるかを検索
>　　　　For Each ws2 In Worksheets
>　　　　　　If ws2.Name = d Then
>　　　　　　　　wsFlg = True
>　　　　　　　　Exit For
>　　　　　　End If
　　　　Next
>
'もしシート名 d のシートがなければシート a をコピーして
'シート名を 変数 d の値に変更
'行位置を13に初期化
>　　　　If Not wsFlg Then
>
'インデント（字下げ）しましょう
　　>　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)
　　>　　　　
　　>　　　　 '↓いれました。
　　>　　　　Worksheets(Worksheets.Count).Name = d
　　>　　　　　　　　
　　>　　　　A = 13
>
>　　　　 Else
>
'シート名 d のシートがあれば
'現在の行位置を検索して、次の行位置を変数Aに設定
>　　　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row + 1
>　　　　End If
>
>　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
>　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
>　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
>　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
>　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
>　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
>　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
>　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
>　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
>　　　　A = A + 1
この下のNext不要
>　　　　Next

>　　Next
>End Sub
【12299】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/30(火) 8:42 -
引用なし
パスワード
   ▼こうちゃん さん：
字下げ注意します。
ところでまだ問題があります。解決法をご教示いただけないでしょうか？
１．あるｼｰﾄに書きこまれるべきﾚｺｰﾄﾞが書きこまれていない。
２．あるｼｰﾄにﾚｺｰﾄﾞが重複して書きこまれている。
３．あるｼｰﾄにおいて、書きこまれたﾚｺｰﾄﾞと次のﾚｺｰﾄﾞの間に空白行がある。
４．あるｼｰﾄにおいて、ｼｰﾄ名とCells(8, 5)に書きこまれた名が異なっている。

　　Sub test()
　　Dim i As Long
　　Dim A As Integer
　　Dim d As String
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim wsFlg As Boolean

　　Set ws1 = Worksheets("一覧")
　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　d = ws1.Cells(i, 10).Value
　　　　wsFlg = False
　　　　For Each ws2 In Worksheets
　　　　　　If ws2.Name = d Then
　　　　　　　　wsFlg = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If Not wsFlg Then
　　　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)
　　　　　　Worksheets(Worksheets.Count).Name = d
　　　　　　A = 13
　　　　 Else
　　　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row + 1
　　　　End If
　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　ActiveSheet.Cells(A, 12).Value = ws1.Cells(i, 13).Value
　　　　A = A + 1
　　Next
End Sub

なお「一覧」のﾚｲｱｳﾄはこうです。（左部分のみ）
+---+---+---+---+---+---+---+---+---+---+-----+
|　 |　A|　B|　C|　D|　E|　F| G | H |　I|　J　|
+---+---+---+---+---+---+---+---+---+---+-----+
|1　| 店|課 |担 |CD | 客 |CD2|客2|得 | 卸|営　 |
+---+---+---+---+---+---+---+---+---+---+-----+
|2　| xx|xx |xx | 01|xx |31 | xx| xx| K | 川崎|
+---+---+---+---+---+---+---+---+---+---+-----+
|3　| xx|xx |xx | 01|xx |32 | xx| xx| F | 宮前|
+---+---+---+---+---+---+---+---+---+---+-----+
|4　| xx|xx |xx | 02|xx |33 | xx| xx| F | 宮前|
+---+---+---+---+---+---+---+---+---+---+-----+
|5　| xx|xx |xx | 03|xx |34 | xx| xx| K | 中原|
+---+---+---+---+---+---+---+---+---+---+-----+
2行目と5行目のﾚｺｰﾄﾞは別ｼｰﾄに、
3行目と4行目のﾚｺｰﾄﾞは同一ｼｰﾄにしなければなりません。
卸が異なるのに営が同じケースはありません。
なおxxはCHARです。
【12305】Re:Caseに続く部分を自動的に持ってこれ...
発言  こうちゃん E-MAIL  - 04/3/30(火) 10:52 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>ところでまだ問題があります。解決法をご教示いただけないでしょうか？
>１．あるｼｰﾄに書きこまれるべきﾚｺｰﾄﾞが書きこまれていない。
>２．あるｼｰﾄにﾚｺｰﾄﾞが重複して書きこまれている。
>３．あるｼｰﾄにおいて、書きこまれたﾚｺｰﾄﾞと次のﾚｺｰﾄﾞの間に空白行がある。
>４．あるｼｰﾄにおいて、ｼｰﾄ名とCells(8, 5)に書きこまれた名が異なっている。

現象が再現できません。

「あるシート」とはどんなシートでどんな状況かこちらではさっぱりわかりません。
どう重複して、どう異なっているかもこちらではぜんぜんわかりません。

もう少し詳細にご説明いただけませんか？

変数の値を確認しながらステップ実行してみてください。
ワークシート画面とVBE画面を交互に参照したり、VBEのデバッグ・ウォッチ式の追加で各変数を確認しながら実行してみてください。


>卸が異なるのに営が同じケースはありません。
この意味は？？
卸が異なるの場合、営はかならず違うってこと？
（同じ卸を使う営はないの意味？コードとなにか関連があるのですか？）
【12306】Re:Caseに続く部分を自動的に持ってこれ...
回答  Asaki  - 04/3/30(火) 11:04 -
引用なし
パスワード
   こんにちは。
後ろから失礼します。

実際の書き込み処理の部分ですが、シートが既にあった場合の
>ActiveSheet
って、どのシートでしょう？
これが違うのでは？
【12316】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/30(火) 14:41 -
引用なし
パスワード
   ▼こうちゃん さん：

>もう少し詳細にご説明いただけませんか？
たとえばわたくしが作った一覧の4ﾚｺｰﾄﾞをｺﾋﾟｰして8ﾚｺｰﾄﾞとします。
それをもって実行すると空白行があるｼｰﾄができませんでしょうか？

>この意味は？？
はい。卸が異なると営は必ずちがうということです。
【12318】Re:Caseに続く部分を自動的に持ってこれ...
発言  こうちゃん E-MAIL  - 04/3/30(火) 15:23 -
引用なし
パスワード
   まだ初心者さん、Asakiさん、こんにちは

Asakiさんに１票！

>　　　　ActiveSheet.Cells(8, 2).Value = ws1.Cells(i, 9).Value
>　　　　ActiveSheet.Cells(8, 5).Value = ws1.Cells(i, 10).Value
>　　　　ActiveSheet.Cells(A, 1).Value = ws1.Cells(i, 4).Value
>　　　　ActiveSheet.Cells(A, 2).Value = ws1.Cells(i, 5).Value
>　　　　ActiveSheet.Cells(A, 3).Value = ws1.Cells(i, 6).Value
>　　　　ActiveSheet.Cells(A, 4).Value = ws1.Cells(i, 7).Value
>　　　　ActiveSheet.Cells(A, 5).Value = ws1.Cells(i, 11).Value
>　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value
>　　　　ActiveSheet.Cells(A, 11).Value = ws1.Cells(i, 12).Value

を下記のようにシートを明示するように変更してみてください。

　　　　Worksheets(d).Cells(8, 2).Value = ws1.Cells(i, 9).Value
　　　　Worksheets(d).Cells(8, 5).Value = ws1.Cells(i, 10).Value
　　　　Worksheets(d).Cells(A, 1).Value = ws1.Cells(i, 4).Value
　　　　Worksheets(d).Cells(A, 2).Value = ws1.Cells(i, 5).Value
　　　　Worksheets(d).Cells(A, 3).Value = ws1.Cells(i, 6).Value
　　　　Worksheets(d).Cells(A, 4).Value = ws1.Cells(i, 7).Value
　　　　Worksheets(d).Cells(A, 5).Value = ws1.Cells(i, 11).Value
　　　　Worksheets(d).Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　Worksheets(d).Cells(A, 12).Value = ws1.Cells(i, 13).Value

＃ステップ実行はしてみましたか？で、その結果はいかがでしたか？

>>この意味は？？
>はい。卸が異なると営は必ずちがうということです。

>>（同じ卸を使う営はないの意味？コードとなにか関連があるのですか？）
こちらの答えは?
【12320】Re:Caseに続く部分を自動的に持ってこれ...
質問  まだ初心者  - 04/3/30(火) 16:29 -
引用なし
パスワード
   ▼こうちゃん さん、Asakiさん、ありがとうございます。

>>＃ステップ実行はしてみましたか？で、その結果はいかがでしたか？
１．２．３．４はすべて解決しました。


>>>（同じ卸を使う営はないの意味？コードとなにか関連があるのですか？）
>こちらの答えは?
営とは卸の営業所です。つまり卸別営別のｼｰﾄを作っています。
また客のｺｰﾄﾞはこの際卸にも営にも関係ありません。

新たな問題がでました。
a(2)という名のｼｰﾄができ、処理が途中で止まってしまいます。
【12322】もう少しわかるようにお願いします。
発言  こうちゃん E-MAIL  - 04/3/30(火) 16:42 -
引用なし
パスワード
   まだ初心者さん、こんにちは

>>>>（同じ卸を使う営はないの意味？コードとなにか関連があるのですか？）
>>こちらの答えは?
>営とは卸の営業所です。つまり卸別営別のｼｰﾄを作っています。
>また客のｺｰﾄﾞはこの際卸にも営にも関係ありません。
私の言っているコードとは、今回のプログラムコードのことで、VBAの処理とは関係ないねってことです^^;

>新たな問題がでました。
>a(2)という名のｼｰﾄができ、処理が途中で止まってしまいます。
ですからそれが見えるのは「まだ初心者さん」だけです。
もっと詳細にお願いします。

>>>＃ステップ実行はしてみましたか？で、その結果はいかがでしたか？
ステップ実行というのはVBEの画面でプログラムを１行ずつ実行することです。
F8キーでプログラムを１行ずつ実行できますので、途中で変数の値を確認したい場合等に有効です。
今回もステップ実行でエラーになるのがどのデータなのかを確認してください。
データの内容（J列に値がないものとか）は不都合なものがないかも確認してみてください。
データが「例」なので同じエラーが再現できないと回答するのが難しいですね。

＃プログラム中にはエラー処理が一切ふくまれていませんので、実用上はエラー処理を追加する必要があります。
【12323】深くなったのでこちらに返信お願いします...
発言  こうちゃん E-MAIL  - 04/3/30(火) 16:44 -
引用なし
パスワード
   ネストを戻しましょう。
【12324】Re:深くなったのでこちらに返信お願いし...
回答  Asaki  - 04/3/30(火) 16:56 -
引用なし
パスワード
   >ws1.Cells(i, 10).Value
が、シート名として使用できない文字を含んでいませんか？
もしくは、空？
または半角31文字以上？
【12325】Re:深くなったのでこちらに返信お願いし...
質問  まだ初心者  - 04/3/30(火) 17:55 -
引用なし
パスワード
   ▼Asaki さん：

>もしくは、空？
ご指摘通り空がありました。
空を取ったら走りだしました。
ものすごい時間がかかっています。
検証し終わったらご連絡します。
【12327】Re:深くなったのでこちらに返信お願いし...
回答  Asaki  - 04/3/30(火) 20:04 -
引用なし
パスワード
   >ものすごい時間がかかっています。
処理が遅いと言うことであれば、別の手を考えたほうが良いかもしれません。
ソートしてから、コードが変わったタイミングでまとめて転記、など。

あと、数式が存在しているなら、一旦自動計算を停止するなど。
【12337】Re:深くなったのでこちらに返信お願いし...
お礼  まだ初心者  - 04/3/31(水) 10:17 -
引用なし
パスワード
   ▼こうちゃんさん、Asakiさん

実行の結果、卸別営別リストはわたくしの意図通りできました。
時間も、ﾃﾞｰﾀを分割したらストレスなく処理できました。
こうちゃん様、Asaki様には心より感謝しております。
もともとはこうちゃん様（いつのまにか様づけになっているが・・）の
初心者には敷居が高いというお言葉に発奮したものの、一人では歯がたたず、
結局ほとんどすべてを頼ったことになってしまいました。
これからは技術の習得に努めたいと思います。
今後ともご指導よろしくお願いいたします。

以下は完成形です。ありがとうございました。

　 Sub test()

　　Dim i As Long
　　Dim A As Integer
　　Dim d As String
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim wsFlg As Boolean

　　Set ws1 = Worksheets("一覧")

　　　For i = 2 To ws1.Range("A65535").End(xlUp).Row
　　　　d = ws1.Cells(i, 10).Value
　　　　wsFlg = False
　　　　For Each ws2 In Worksheets
　　　　　　If ws2.Name = d Then
　　　　　　　　wsFlg = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next

　　　　If Not wsFlg Then
　　　　　　Worksheets("a").Copy after:=Worksheets(Worksheets.Count)
　　　　　　Worksheets(Worksheets.Count).Name = d
　　　　　　A = 13
　　　　 Else
　　　　　　A = Worksheets(d).Range("A65536").End(xlUp).Row + 1
　　　　End If

　　　　Worksheets(d).Cells(8, 2).Value = ws1.Cells(i, 9).Value
　　　　Worksheets(d).Cells(8, 5).Value = ws1.Cells(i, 10).Value
　　　　Worksheets(d).Cells(A, 1).Value = ws1.Cells(i, 4).Value
　　　　Worksheets(d).Cells(A, 2).Value = ws1.Cells(i, 5).Value
　　　　Worksheets(d).Cells(A, 3).Value = ws1.Cells(i, 6).Value
　　　　Worksheets(d).Cells(A, 4).Value = ws1.Cells(i, 7).Value
　　　　Worksheets(d).Cells(A, 5).Value = ws1.Cells(i, 11).Value
　　　　Worksheets(d).Cells(A, 11).Value = ws1.Cells(i, 12).Value
　　　　Worksheets(d).Cells(A, 12).Value = ws1.Cells(i, 13).Value
　　　　A = A + 1
　　Next

End Sub
【12338】おつかれさまでした＾＾
発言  こうちゃん E-MAIL  - 04/3/31(水) 10:45 -
引用なし
パスワード
   まだ初心者さん、こんにちは
そしてお疲れ様でした。

>初心者には敷居が高いというお言葉に発奮したものの、一人では歯がたたず、

「敷居が高い」の受け取り方に誤解があったようですので一言だけ・・

当初まだ初心者さんはこうおっしゃっていました。
>>そのリストにある全営業所をﾌﾟﾛｸﾞﾗﾑにCase "○○営"として
>>自動的に持って来ることは可能でしょうか？

私が「敷居が高い」といったのは、完成形で提示されたようなプログラムを組むことにたいしてではなく、「プログラムにCase "○○営"として自動的に持って来ること」つまりプログラムコードの自動生成に取り組むのは初心者には敷居が高いといったつもりだったのです。（私も自信ありません）

私ごとですが、４月１日より職場が異動いたしますことから、ここに書き込みができるのが本日までとなるかもしれません。少しあせっていたせいで、途中きつい物言いをしたような気もいたしますが、よくがんばっていただき完成形までいたっていただいたことをお礼申し上げます。

Asakiさん、フォローありがとうございました。
【12339】Re:おつかれさまでした＾＾
発言  Asaki  - 04/3/31(水) 10:58 -
引用なし
パスワード
   皆様、お疲れ様でした。

>Asakiさん、フォローありがとうございました。
いえいえ。
横から眺めて口挟むだけでしたので、気楽です。(^_^;

>４月１日より職場が異動いたしますことから、ここに書き込みができるのが
>本日までとなるかもしれません。
新しい職場でのご活躍をお祈りしております。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
12107 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free