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すら出来ていません。
>いったいどこを直せばよいのでしょうか。

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

こんな感じでいかがでしょう?
#少し冗長ですがわかりやすさ優先ということで(^^;)
#変数はある程度意味を持たせたほうが可読性があがります。
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 -

引用なし
パスワード
   ▼こうちゃん さん:
字下げ注意します。
ところでまだ問題があります。解決法をご教示いただけないでしょうか?
1.あるシートに書きこまれるべきレコードが書きこまれていない。
2.あるシートにレコードが重複して書きこまれている。
3.あるシートにおいて、書きこまれたレコードと次のレコードの間に空白行がある。
4.あるシートにおいて、シート名と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 -

引用なし
パスワード
   まだ初心者さん、こんにちは

>ところでまだ問題があります。解決法をご教示いただけないでしょうか?
>1.あるシートに書きこまれるべきレコードが書きこまれていない。
>2.あるシートにレコードが重複して書きこまれている。
>3.あるシートにおいて、書きこまれたレコードと次のレコードの間に空白行がある。
>4.あるシートにおいて、シート名と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さんに1票!

>    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さん、ありがとうございます。

>>#ステップ実行はしてみましたか?で、その結果はいかがでしたか?
1.2.3.4はすべて解決しました。


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

新たな問題がでました。
a(2)という名のシートができ、処理が途中で止まってしまいます。

【12322】もう少しわかるようにお願いします。
発言  こうちゃん E-MAIL  - 04/3/30(火) 16:42 -

引用なし
パスワード
   まだ初心者さん、こんにちは

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

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

>>>#ステップ実行はしてみましたか?で、その結果はいかがでしたか?
ステップ実行というのはVBEの画面でプログラムを1行ずつ実行することです。
F8キーでプログラムを1行ずつ実行できますので、途中で変数の値を確認したい場合等に有効です。
今回もステップ実行でエラーになるのがどのデータなのかを確認してください。
データの内容(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 "○○営"として自動的に持って来ること」つまりプログラムコードの自動生成に取り組むのは初心者には敷居が高いといったつもりだったのです。(私も自信ありません)

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

Asakiさん、フォローありがとうございました。

【12339】Re:おつかれさまでした^^
発言  Asaki  - 04/3/31(水) 10:58 -

引用なし
パスワード
   皆様、お疲れ様でした。

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

>4月1日より職場が異動いたしますことから、ここに書き込みができるのが
>本日までとなるかもしれません。
新しい職場でのご活躍をお祈りしております。

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