Excel VBA質問箱 IV

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

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


3273 / 13645 ツリー ←次へ | 前へ→

【63091】特定の文字を含むシートだけを移動させる方法 けい 09/10/7(水) 15:16 質問[未読]
【63092】Re:特定の文字を含むシートだけを移動させ... Jaka 09/10/7(水) 15:41 発言[未読]
【63113】Re:特定の文字を含むシートだけを移動させ... けい 09/10/9(金) 9:20 お礼[未読]
【63093】Re:特定の文字を含むシートだけを移動させ... Yuki 09/10/7(水) 15:48 発言[未読]
【63114】Re:特定の文字を含むシートだけを移動させ... けい 09/10/9(金) 9:25 質問[未読]
【63115】Re:特定の文字を含むシートだけを移動させ... けい 09/10/9(金) 10:23 質問[未読]
【63116】Re:特定の文字を含むシートだけを移動させ... Yuki 09/10/9(金) 11:20 発言[未読]
【63117】Re:特定の文字を含むシートだけを移動させ... けい 09/10/9(金) 12:02 質問[未読]
【63118】Re:特定の文字を含むシートだけを移動させ... Jaka 09/10/9(金) 13:34 発言[未読]
【63174】Re:特定の文字を含むシートだけを移動させ... けい 09/10/13(火) 8:03 質問[未読]
【63119】Re:特定の文字を含むシートだけを移動させ... Yuki 09/10/9(金) 15:27 発言[未読]
【63175】Re:特定の文字を含むシートだけを移動させ... けい 09/10/13(火) 8:05 質問[未読]
【63176】Re:特定の文字を含むシートだけを移動させ... Yuki 09/10/13(火) 8:58 発言[未読]
【63177】Re:特定の文字を含むシートだけを移動させ... けい 09/10/13(火) 10:00 発言[未読]
【63178】Re:特定の文字を含むシートだけを移動させ... seg 09/10/13(火) 12:58 発言[未読]
【63179】Re:特定の文字を含むシートだけを移動させ... けい 09/10/13(火) 15:13 発言[未読]
【63180】Re:特定の文字を含むシートだけを移動させ... seg 09/10/13(火) 15:42 発言[未読]
【63181】Re:特定の文字を含むシートだけを移動させ... Yuki 09/10/13(火) 15:48 発言[未読]
【63182】Re:特定の文字を含むシートだけを移動させ... けい 09/10/13(火) 16:35 発言[未読]
【63184】Re:特定の文字を含むシートだけを移動させ... seg 09/10/13(火) 17:27 発言[未読]
【63187】Re:特定の文字を含むシートだけを移動させ... けい 09/10/14(水) 8:26 お礼[未読]
【63188】Re:特定の文字を含むシートだけを移動させ... Yuki 09/10/14(水) 8:35 発言[未読]
【63193】Re:特定の文字を含むシートだけを移動させ... けい 09/10/15(木) 9:16 お礼[未読]

【63091】特定の文字を含むシートだけを移動させる...
質問  けい  - 09/10/7(水) 15:16 -

引用なし
パスワード
   特定の文字を含むシートを別ブックに移動させて、
指定されたフォルダに作成したファイルを入れる…といった動作をさせたいと思っていますが、どうもうまくいかなくて困っています

分かる方、よろしくお願いします

例えばシート名には、下記のようなシートが6つ存在しているとします
その中で、[ABCDEF]を含むシートを新規ファイルを作成して、移動させたいのです。
ちなみに[ABCDRF]の部分は、変更します
(セルA5の値を参照するため)
設定,手順,転送,ABCDEF ,ABCDEF(1),ABCDEF(2)

現在のコードは下記の通りです

Sub ブック作成()
Dim BookName As String
Dim MasBook As String
Dim ShName As String

MasBook = ThisWorkbook.Name

BookName = Range("A5").Value

Set Newbook = Workbooks.Add
Newbook.SaveAs FileName:=BookName
シート名 = ActiveSheet.Name

Workbooks(MasBook).Activate
For Each 各シート In Workbooks(MasBook).Sheets

If 各シート.Name = BookName & "*" Then

’↑ここのワイルドカードの使い方がよくないんでしょうか?

Worksheets(各シート.Name).Copy after:=Workbooks(BookName).Sheets(シート名)
シート名 = 各シート.Name
Workbooks(MasBook).Activate
End If
Next
Workbooks(BookName).Activate

End Sub

【63092】Re:特定の文字を含むシートだけを移動さ...
発言  Jaka  - 09/10/7(水) 15:41 -

引用なし
パスワード
   ワイルドカードなら、Like 演算子をヘルプで見て下さい。

他、
st = "ABCDEFG"
If InStr(1, st, "EFG") > 0 Then
  EFGある
Else
  EFGない
End If

とか。

【63093】Re:特定の文字を含むシートだけを移動さ...
発言  Yuki  - 09/10/7(水) 15:48 -

引用なし
パスワード
   ▼けい さん:
>If 各シート.Name = BookName & "*" Then
>
>’↑ここのワイルドカードの使い方がよくないんでしょうか?
    ↓
If 各シート.Name Like BookName & "*" Then

で良いと思いますが。

【63113】Re:特定の文字を含むシートだけを移動さ...
お礼  けい  - 09/10/9(金) 9:20 -

引用なし
パスワード
   ▼Jaka さん:

返事遅くなってしまってすみません

ずっと悪戦苦闘してました

アドバイスありがとうございました
 Likeを使って、移動させることができました

【63114】Re:特定の文字を含むシートだけを移動さ...
質問  けい  - 09/10/9(金) 9:25 -

引用なし
パスワード
   ▼Yuki さん:
返事が遅くなってすみません

なかなかうまくいかなくて困ってます

>If 各シート.Name Like BookName & "*" Then
>
アドバイス通り、上記のコードに変えてみました。
上記の問題は解決したのですが、どうも移動したあとの、
[シート名]=[各シート.Name]の部分でオートメーションエラーになってしまい、
次のシートを移動することができません。

Worksheets(各シート.Name).Move after:=Workbooks(BookName).Sheets(シート名)
シート名 = 各シート.Name

また、移動するシートは常にシートの最後尾に入れていきたいのですが、
Worksheets(各シート.Name).Move after:=Workbooks(BookName).Sheets(Worksheet.count)
にするとエラーになってしまいます

どうすれば解決できるのでしょうか??

お願いします

【63115】Re:特定の文字を含むシートだけを移動さ...
質問  けい  - 09/10/9(金) 10:23 -

引用なし
パスワード
   とりあえず、下記のようにコードを作ってみました。

ところが、途中で、
実行時エラ− '1004':
worksheetクラスのMoveメソッドが失敗しました

とエラーが表示されてしまいます

なぜ、このようなエラーがでるのか?分かりません。
コードに問題があるのでしょうか?

アドバイスお願いします

Sub BOOK()

Dim BookName As String
Dim MasBook As String
Dim WS As Worksheet
Dim ShC As Variant


MasBook = ThisWorkbook.Name
BookName = Range("E5").Value

Application.DisplayAlerts = False

Set Newbook = Workbooks.Add
Newbook.SaveAs FileName:=BookName

Worksheets(Array("Sheet2", "Sheet3")).Delete

Application.DisplayAlerts = True


Workbooks(MasBook).Activate

ShC = 1
For Each WS In Workbooks(MasBook).Sheets

If WS.Name Like BookName & "*" Then
Worksheets(WS.Name).Move after:=Workbooks(BookName).Sheets(ShC)
ShC = Worksheets.Count
Workbooks(MasBook).Activate
End If
Next
Workbooks(BookName).Activate

Application.DisplayAlerts = False
Worksheets(Array("Sheet1")).Delete


ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & BookName
ActiveWorkbook.Close

Application.DisplayAlerts = True
End Sub

【63116】Re:特定の文字を含むシートだけを移動さ...
発言  Yuki  - 09/10/9(金) 11:20 -

引用なし
パスワード
   ▼けい さん:

こんにちは。
ThisworkbookのあるシートのA5の値と同じシート名を
新規ブックにコピーしたいという事でしょうか?

変数名は変えてありますので
A5の値でNewBookをSaveしていますがそれでいいのですか?
Sub Test()
  Dim strBook As String
  Dim NewBook As Workbook
  Dim sht   As Worksheet
  Dim strSht As String
  Dim vSht  As Variant
  Dim i    As Long
  
  With ThisWorkbook   '________ <=シート名は?
    strBook = .Sheets("Sheet1").Range("A5").Value 'FullPathが入っているか?
    'FullPathが入っている時検索シート用のData
    If InStr(strBook, "\") > 0 Then
      vSht = Split(strBook, "\")
      strSht = Left(vSht(UBound(vSht)), InStrRev(vSht(UBound(vSht)), ".") - 1)
    Else
      If InStr(strBook, ".") > 0 Then
        strSht = Left(strBook, InStrRev(strBook, ".") - 1)
      Else
        strSht = strBook
        strBook = strBook & ".xls"
      End If
    End If
    For Each sht In .Worksheets
      If sht.Name Like strSht & "*" Then
        i = i + 1
        If i = 1 Then
          sht.Copy
          Set NewBook = ActiveWorkbook
        Else
          sht.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count)
        End If
      End If
    Next
  End With
  NewBook.SaveAs strBook
End Sub

【63117】Re:特定の文字を含むシートだけを移動さ...
質問  けい  - 09/10/9(金) 12:02 -

引用なし
パスワード
   ▼Yuki さん:


>こんにちは。

アドバイスありがとうございます

このままコードを記述してみたところ、動きましたが、
コピーではなく、移動させたいと思ってます

[Copy]の箇所を[Move]に変えて、動かしてみたところ、
やっぱり途中で、実行時エラー ’1004’が表示され、
Moveメソッドが失敗しました、’Worksheet'オブジェクト

とでてしまいます

なんででしょうか??
書き方に問題でもあるのでしょうか?
教えて下さい

何度も質問して申し訳ありません。


>    For Each sht In .Worksheets
>      If sht.Name Like strSht & "*" Then
>        i = i + 1
>        If i = 1 Then
>          sht.Copy  ’←ここを[sht.Move]に変えました
>          Set NewBook = ActiveWorkbook
>        Else
>          sht.Copy After:=NewBook.Worksheets (NewBook.Worksheets.Count) ’←ここを[sht.Move After:=NewBook.Worksheets (NewBook.Worksheets.Count)]と変えました


どうか、よろしくお願いします

【63118】Re:特定の文字を含むシートだけを移動さ...
発言  Jaka  - 09/10/9(金) 13:34 -

引用なし
パスワード
   Move という文字を選択して、F1キーを押してみてください。

【63119】Re:特定の文字を含むシートだけを移動さ...
発言  Yuki  - 09/10/9(金) 15:27 -

引用なし
パスワード
   ▼けい さん:

>このままコードを記述してみたところ、動きましたが、
>コピーではなく、移動させたいと思ってます
>
>[Copy]の箇所を[Move]に変えて、動かしてみたところ、
>やっぱり途中で、実行時エラー ’1004’が表示され、
>Moveメソッドが失敗しました、’Worksheet'オブジェクト
>
>とでてしまいます
>
>なんででしょうか??
>sht.Copy After:=NewBook.Worksheets (NewBook.Worksheets.Count) ’←ここを[sht.Move After:=NewBook.Worksheets (NewBook.Worksheets.Count)]と変えました


まさかと思いますが全部のシートが対象となっていませんか?
こちらでは再現できませんでした。

【63174】Re:特定の文字を含むシートだけを移動さ...
質問  けい  - 09/10/13(火) 8:03 -

引用なし
パスワード
   ▼Jaka さん:
>Move という文字を選択して、F1キーを押してみてください。

アドバイスありがとうございます

F1キーを押してみました、
ヘルプファイルというものが表示されましたが…
これをどうすればよいのでしょうか??

【63175】Re:特定の文字を含むシートだけを移動さ...
質問  けい  - 09/10/13(火) 8:05 -

引用なし
パスワード
   ▼Yuki さん:

>
>まさかと思いますが全部のシートが対象となっていませんか?
>こちらでは再現できませんでした。


アドバイスありがとうございます

ファイル内のシート全部のうち、一部の文字を含むシートだけを移動させるというようにしたいのですが、そうすると、全部のシートが対象ということになってます

これが、よくないのでしょうか?

【63176】Re:特定の文字を含むシートだけを移動さ...
発言  Yuki  - 09/10/13(火) 8:58 -

引用なし
パスワード
   ▼けい さん:
>
>ファイル内のシート全部のうち、一部の文字を含むシートだけを移動させるというようにしたいのですが、そうすると、全部のシートが対象ということになってます
>
>これが、よくないのでしょうか?

    For Each sht In .Worksheets
      If sht.Name Like strSht & "*" Then
        i = i + 1
        If i = 1 Then
          sht.Move
          Set NewBook = ActiveWorkbook
        Else
          sht.Move After:=NewBook.Worksheets(NewBook.Worksheets.Count)
        End If
      End If
    Next
sht.Moveで全部移動したらブックが無くなりますよ。
この時にエラーメッセージが出ると思いますが。
私の解釈が間違っていたら
シート名を全部と移動するシート名の一部(strShtの内容)を
挙げて下さい。

【63177】Re:特定の文字を含むシートだけを移動さ...
発言  けい  - 09/10/13(火) 10:00 -

引用なし
パスワード
   ▼Yuki さん:

お返事ありがとうございます

どうしても、いまいち意味が理解できなくて…

別ブックにコピーしてから、元ファイルのほうをシート削除することにしました

いろいろと複雑の為か、うまくいく場合とうまくいかない場合があるのは、仕方のないことなのでしょうか?

たまに、コピー処理する際にエラーが出てきたりします

[実行時エラー”1004”
WorksheetクラスのCopyメソッドが失敗しました]…と


うまくいくこともあるので、一回エラーが出た場合は、ファイルを一回閉じてから
また開いて処理をするとうまくいったりします

【63178】Re:特定の文字を含むシートだけを移動さ...
発言  seg  - 09/10/13(火) 12:58 -

引用なし
パスワード
   関連箇所のソースを見せてください。

【63179】Re:特定の文字を含むシートだけを移動さ...
発言  けい  - 09/10/13(火) 15:13 -

引用なし
パスワード
   ▼seg さん:

こんにちは!

コピーすることが多くて、関連場所はいろいろありますが、
まず一つは、下記の部分でエラーがでます

Worksheets("原紙").Copy after:=Worksheets(Sheets.Count)  ’ここでエラーが発生します

   Worksheets(Sheets.Count).Name = Parts & "_" & Format(号Start, "0000")

【63180】Re:特定の文字を含むシートだけを移動さ...
発言  seg  - 09/10/13(火) 15:42 -

引用なし
パスワード
   何が、どのようになっているのか理解するのに情報が足りません。
Yukiさんを始め、皆さんに協力いただくには
状況を細かく解りやすく、伝えてください。

www.vbalab.net/bbspolicy.html

> Worksheets("原紙").Copy after:=Worksheets(Sheets.Count)  ’ここでエラーが発生します
>
>   Worksheets(Sheets.Count).Name = Parts & "_" & Format(号Start, "0000")

このソースですが、何のエラーが出たのかが解りません。
ソース自体に問題はありません。
簡単に想像するなら、"原紙"シートが存在しない。
または、存在してるけど、違うワークブック等がアクティブになっていて
認識出来ないかな。

何にしても、情報が無いと回答できません。

【63181】Re:特定の文字を含むシートだけを移動さ...
発言  Yuki  - 09/10/13(火) 15:48 -

引用なし
パスワード
   こんにちは。

seg さんもおっしゃっていますが
>または、存在してるけど、違うワークブック等がアクティブになっていて
>認識出来ないかな。
>
>何にしても、情報が無いと回答できません。

多分ブックの参照が無いためと思われます。

【63182】Re:特定の文字を含むシートだけを移動さ...
発言  けい  - 09/10/13(火) 16:35 -

引用なし
パスワード
   ▼seg さん:
▼Yukiさん:

すみません
情報が足りなさすぎでした。

今、下記のようにコードを記述してます
エラーが出るまでのところまで記載します

Private Sub CommandButton1_Click()

Dim 号Start As Integer, 号End As Integer
Dim SFX As String, WO As String
Dim WO最終行 As Integer

'********************
Dim LastR As Integer
Dim ShBOM As Worksheet, ShMas1 As Worksheet, ShMas2 As Worksheet, ShMas3 As Worksheet, ShWO As Worksheet
Dim Lev As Variant, Lev2 As Variant, Tar As Variant
Dim Parts As String, TopParts As String
Dim TopRange As Range
Dim TopKey As Integer
Dim MyLen As Integer, Pos As Integer
Dim EC As Variant
Dim MyType As Variant
Dim F判定 As Variant
Dim F As Variant
Dim MAPLNo As Integer
Dim Mas1R As Integer, Mas2R As Integer, Mas3R As Integer
Dim WS1 As Worksheet, flag As Boolean
Dim WS2 As Worksheet, flag2 As Boolean
Dim WS3 As Worksheet, flag3 As Boolean

Set ShWO = Worksheets("WO")

'号機情報
  If UserForm2.LineStxt = "" Then
    MsgBox "号機を入力して下さい"
    'End
    Exit Sub
  Else
     If UserForm2.LineStxt.Value = UserForm2.LineEtxt.Value Or LineEtxt.Value = "" Then
       号Start = UserForm2.LineStxt.Value
       号End = UserForm2.LineStxt.Value
     Else
       号Start = UserForm2.LineStxt.Value
       号End = UserForm2.LineEtxt.Value
     End If
     
  End If
  
  'SFX
  If UserForm2.OptionButton1.Value Then
    SFX = "-101"
    WO = "部品用"
  ElseIf UserForm2.OptionButton2.Value Then
    SFX = "-201"
    WO = "部品用"
  ElseIf UserForm2.OptionButton3.Value Then
    SFX = "-301"
    WO = "部品用"
  ElseIf UserForm2.OptionButton4.Value Then
    SFX = "-111"
    WO = "部品用"
  ElseIf UserForm2.OptionButton8.Value Then
    SFX = "-101"
    WO = "組立用"
  ElseIf UserForm2.OptionButton6.Value Then
    SFX = "-201"
    WO = "組立用"
  ElseIf UserForm2.OptionButton5.Value Then
    SFX = "-301"
    WO = "組立用"
  ElseIf UserForm2.OptionButton7.Value Then
    SFX = "-111"
    WO = "組立用"
  Else
    MsgBox "WOを選択して下さい"
    'End
    Exit Sub
    
  End If
  
Set ShBOM = Worksheets("BOM")
LastR = ShBOM.Range("B65536").End(xlUp).Row

For i = 11 To LastR
If ShBOM.Range("A" & i).Value = "★" Then

   Lev = ShBOM.Range("B" & i).Value '階層
   Parts = ShBOM.Range("D" & i).Value '部品番号
   Worksheets("原紙").Copy after:=Worksheets(Sheets.Count) ’←ここでたまにエラーがでます
   Worksheets(Sheets.Count).Name = Parts & "_" & Format(号Start, "0000")
       
     Set ShMas1 = Worksheets(Parts & "_" & Format(号Start, "0000"))

うまくいくときもあればうまくいかなくなるときもあります
どう、回避をしたらいいのでしょうか?
よろしくお願いします

【63184】Re:特定の文字を含むシートだけを移動さ...
発言  seg  - 09/10/13(火) 17:27 -

引用なし
パスワード
   余談ですが何か、ツリーがごちゃごちゃしてますね^^;

えと、私の言った詳しくと言うのは、ソースも勿論なのですが、
その環境と言うか、操作状況(ボタンを押した時の)みたいのが
有ったほうが。

要求仕様を考えると、複数のブックが同時に立ち上がってるの
ですよね?

もし、ブックが1つで、
○○ブックの○○シートにボタンが配置してあり、ボタンを押すと
フォームがShow(1?)される。フォームの入力チェックしてOKなら
処理開始。

上記のように処理した場合、○○ブック内に"原紙"シートがあるなら
エラーには、ならないと思います。

○○ブックの○○シートからフォームを呼び出し、フォームに
値(オプション等)を設定しながら、××ブックを自身で参照するために
アクティブにしたりしてませんか?

複数ブックがあるなら、ブックから指定しないとエラーが起きる可能性は
あります。

ごめんなさい、他に浮かばないです。

【63187】Re:特定の文字を含むシートだけを移動さ...
お礼  けい  - 09/10/14(水) 8:26 -

引用なし
パスワード
   ▼seg さん:

いろいろアドバイスありがとうございます

segさんのおっしゃった内容などを含め、もう一度、確認してみます

ありがとうございました

【63188】Re:特定の文字を含むシートだけを移動さ...
発言  Yuki  - 09/10/14(水) 8:35 -

引用なし
パスワード
   ▼けい さん:
注釈をつけて見ました
一部添削あります。

  Set ShWO = Worksheets("WO") '←ブック名を指定

  '号機情報
  With UserForm2
    If .LineStxt = "" Then
      MsgBox "号機を入力して下さい"
      'End
      Exit Sub
    Else
      If .LineStxt.Value = .LineEtxt.Value Or .LineEtxt.Value = "" Then
        号Start = .LineStxt.Value
        号End = .LineStxt.Value
      Else
        号Start = .LineStxt.Value
        号End = .LineEtxt.Value
      End If
    End If
 
  'SFX
    Select Case True
      Case .OptionButton1.Value
        SFX = "-101"
        WO = "部品用"
      Case .OptionButton2.Value
        SFX = "-201"
        WO = "部品用"
      Case .OptionButton3.Value
        SFX = "-301"
        WO = "部品用"
      Case .OptionButton4.Value
        SFX = "-111"
        WO = "部品用"
      Case .OptionButton5.Value
        SFX = "-301"
        WO = "組立用"
      Case .OptionButton6.Value
        SFX = "-201"
        WO = "組立用"
      Case .OptionButton7.Value
        SFX = "-111"
        WO = "組立用"
      Case .OptionButton8.Value
        SFX = "-101"
        WO = "組立用"
      Case Else
        MsgBox "WOを選択して下さい"
        'End
        Exit Sub
    End Select
  End With
  
  Set ShBOM = Worksheets("BOM") '← ブック名を指定
  LastR = ShBOM.Range("B65536").End(xlUp).Row

  For i = 11 To LastR
    If ShBOM.Range("A" & i).Value = "★" Then
      Lev = ShBOM.Range("B" & i).Value '階層
      Parts = ShBOM.Range("D" & i).Value '部品番号
     '↓ コピー元ブック名指定    ↓ コピー先のブック名指定
      Worksheets("原紙").Copy after:=Worksheets(Sheets.Count) '←ここでたまにエラーがでます
     '↓ コピー先のブック名指定
      Worksheets(Sheets.Count).Name = Parts & "_" & Format(号Start, "0000")
            '↓ コピー先のブック名指定
      Set ShMas1 = Worksheets(Parts & "_" & Format(号Start, "0000"))

【63193】Re:特定の文字を含むシートだけを移動さ...
お礼  けい  - 09/10/15(木) 9:16 -

引用なし
パスワード
   ▼Yuki さん:

ありがとうございます

ブック名を入れていかないと駄目なんですね…

試してみます

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