こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

回答受付中の質問

Excel VBA 特定の文字を含むシートを移動

VBA初心者です。

2つのブック(ブック1、ブック2)があり、ブック2でシート名に”●●支店”という文字を含むシートをすべてブック1にコピーしたいです。

支店名はいろいろあるのでinputboxで検索したいです。

VBAを最近実践し始めたところなので、いろいろ調べたものの全く応用がききません。
どなたか教えて頂ける方、よろしくお願いいたします。

投稿日時 - 2017-11-14 19:49:06

QNo.9397371

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

もう処理期限がすんだのだろうが、やってみたので参考に。
シート名は、同じものはエラーになって許されないことを念頭に下記をいた。
ーー
このコードの記述は、「シートの移動元のブック」の標準モジュールに
Sub test01()
MsgBox ThisWorkbook.Sheets.Count
Workbooks.Open "XXX.xlsx" ’移動先のブック
Set wb2 = Workbooks("XXX.xlsx") '移動先のブックを変数に格納
sn = InputBox("移すシート名")
MsgBox sn
For Each s In ThisWorkbook.Worksheets 'VBAコードを入れているブックのシートの各々について
MsgBox s.Name & "-" & sn

If s.Name = sn Then '入力シート名と同じか
MsgBox "見つかった"
'--見つかった時の処理
'--移動先ブックで同名のシートはないかチェック
For Each sh2 In Worksheets
If sh2.Name = sn Then
MsgBox "同じ名前のシートがあります"
Exit Sub '処理中止
End If
Next
MsgBox "同じ名前のシートはありません"
s.Move after:=wb2.Sheets(wb2.Sheets.Count) '主目的のシートの移動実行
wb2.Close
Exit Sub
End If
Next
MsgBox "見つかりません"
End Sub
実行がうまく行ったらMsgboxの行は削除のこと。一歩ずつ確認用です。
xxxブックに移動するシート名と同じシートは移動先ブックに置かないこと。
テストのつど元の状態(移動したシートは削除しておくこと。)
テストで移動したシートは元のブックに戻してテストすること。
移動先でどこにシートを位置づけるのか指定はないが、勉強のこと。
>VBAを最近実践し始めたところなので
こんな課題に手を付けるのは早すぎると思う。
コピペしてできても、これだけだと、身に付かない。
質問する前にマクロの記録を調べるとかWEBの関連記事を調べるとか、
質問を自分の困難点にまで絞れるようになること。
なぜ自力でできないのにVBAでやるのか。手動の操作がちゃんと存在するのに。

投稿日時 - 2017-11-15 21:02:59

ANo.1

ワイルドカードが使えます。
“●●支店”を検索したい場合、“*支店”と入力してください。
マクロは、Book1 に入れて、そこで実行してください。
'
Option Explicit
'
Sub Macro1()
'  ブック2でシート名に文字を含むシートをブック1にコピーする
  Dim Search As String
  Dim Book2Sheet As Worksheet
  Dim Count As Integer
'  キーワード入力
  Search = InputBox("検索文字")
  If Search = "" Then
    End
  End If
'  シートの削除
  Application.DisplayAlerts = False
  Do While Sheets.Count > 1
    Sheets(2).Delete
  Loop
  Application.DisplayAlerts = True
'  コピー
  For Each Book2Sheet In Workbooks("Book2.xlsx").Worksheets
'    キーワードが見つかれば実行
    If Book2Sheet.Name Like Search Then
      Count = Count + 1
'      シート2以降追加
      If Count > 1 Then
        Sheets.Add After:=Sheets(Sheets.Count)
      End If
      Book2Sheet.Cells.Copy Sheets(Count).[A1]
      Sheets(Count).Name = Book2Sheet.Name
    End If
  Next Book2Sheet
End Sub

投稿日時 - 2017-11-15 10:32:58

お礼

SI299792 さん、ご回答ありがとうございました。
どうしても今日の朝必要だったので自分なりに簡易的に書いてみました↓

Sub シート検索から移動()

Dim sh As Worksheet
Dim text As String

Workbooks.Open Filename:= _
"C:~Book2.xlsx"

text = InputBox(Prompt:="シート検索文字列")

For Each sh In Worksheets
If sh.Name Like "*"& text & "*" Then
Application.DisplayAlerts = False
sh.Copy Before:=Workbooks("Book1.xlsm").Sheets(3)

Application.DisplayAlerts = True
End If
Next sh

End Sub

なんとかこれで進みました。
初心者なもので、回答していただいたコードは全部は理解できませんでした。。
もっと勉強しようと思います。お時間割いていただいてありがとうございました。

投稿日時 - 2017-11-15 20:15:00