Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : 指定なし)
シートを指定して貼りつけたい
投稿日時: 19/05/23 11:28:39
投稿者: paobon

VBAでシートを指定しデータのコピー&ペーストを行いたいです。
知識不足のため、お力をお貸しいただけると幸いです。
 
If bCheck1 = True Then
       '「PASTE」シートを表示
       Worksheets("PASTE").Activate
       MsgBox "NG" & vbCrLf & "「PASTE」シートに番号を入力してください!!", vbCritical, "チェック結果"
         
         
     
       '「AAAA」シートを表示
   ElseIf Not iCheck4 = 1 Then
       Worksheets("AAAA").Activate
        Range(Selection, Selection.End(xlDown)).Copy Worksheets("No.P通し番号_番号").Range("a19")
        Worksheets("No.P通し番号_番号").Activate
        MsgBox "OK" & vbCrLf & vbCrLf & _
                msg●● & msg●● & vbCrLf & vbCrLf & msg●● & msg●●, vbInformation, "チェック結果"
         
         
       '「BBBB」シートを表示
   ElseIf iCheck2 = 2 Then
         Worksheets("BBBB").Activate
         Range(Selection, Selection.End(xlDown)).Copy Worksheets("No.P通し番号_番号").Range("a19")
         Worksheets("No.P通し番号_番号").Activate
         MsgBox "OK" & vbCrLf & vbCrLf & _
                msg●● & msg●● & vbCrLf & vbCrLf & msg●● & msg●●, vbInformation, "チェック結果"
                  
        
    Else
     
       '「check」のチェック結果を表示
       Worksheets("CCCC").Activate
       MsgBox "NG" & vbCrLf & "やり直してください!!", vbCritical, "チェック結果"
   End If
  
 "No.P通し番号_番号"シートはその時により枚数が変わります。
 "AAAA"及び"BBBB"シートのA列に記載される番号と
 "No.P通し番号_番号"のシート名の番号かもしくは"No.P通し番号_番号"シートのD4のセルに記載がある番号が同一のシートのA19へ貼り付けを行いたいです。
 
説明が分かりにくく大変申し訳ありません。
お手数おかけしますが、よろしくお願いいたします。
 
※投稿内容を一部「●●」と修正しました(モーグ運営事務局)

回答
投稿日時: 19/05/23 12:05:33
投稿者: sk

引用:
"No.P通し番号_番号"シートはその時により枚数が変わります

引用:
"No.P通し番号_番号"のシート名の番号
もしくは"No.P通し番号_番号"シートのD4のセルに記載がある番号

"No.P通し番号_1", "No.P通し番号_2", "No.P通し番号_3" のように、
「ある一定の文字列」と「任意の番号(連番)」を組み合わせた
(規則性のある)名前がつけられたワークシートが、
1つのブックの中にいくつもある、という意味でおっしゃっているのでしょうか。

投稿日時: 19/05/23 12:36:12
投稿者: paobon

引用:
"No.P通し番号_1", "No.P通し番号_2", "No.P通し番号_3" のように、
「ある一定の文字列」と「任意の番号(連番)」を組み合わせた
(規則性のある)名前がつけられたワークシートが、
1つのブックの中にいくつもある、という意味でおっしゃっているのでしょうか。
 
説明が疎く申し訳ありません。
 
"No.P通し番号_番号"の通し番号の箇所の値は連番
_番号の個所は16桁の値が入ります(連番ではないランダムな値です)
 
"No.P1_2019052320190523", "No.P2_2019010120190101", "No.P3_2018050520190505"・・・
のシートが1つのブック内に存在しています。

回答
投稿日時: 19/05/23 14:15:55
投稿者: sk

引用:
"No.P通し番号_番号"の通し番号の箇所の値は連番
_番号の個所は16桁の値が入ります(連番ではないランダムな値です)
  
"No.P1_2019052320190523", "No.P2_2019010120190101", "No.P3_2018050520190505"・・・
のシートが1つのブック内に存在しています。

引用:
"AAAA"及び"BBBB"シートのA列に記載される番号と
 "No.P通し番号_番号"のシート名の番号か
もしくは"No.P通し番号_番号"シートのD4のセルに記載がある番号が
同一のシートのA19へ貼り付けを行いたいです。

・ワークシート[AAAA](または[BBBB])の A 列の
 どの行のセルの値と比較するのか。
 
・その( A 列の)セルには「通し番号」と「番号」のどちらが入力されているのか。
 
引用:
Worksheets("AAAA").Activate
Range(Selection, Selection.End(xlDown)).Copy Worksheets("No.P通し番号_番号").Range("a19")

コピー元のセル範囲は上記の通りで本当に間違いないのか。
(その時点でどのセル(セル範囲)が選択されているかによって
 コピー元のセル範囲が変わるコードになっている)

投稿日時: 19/05/23 14:30:41
投稿者: paobon

引用:

・ワークシート[AAAA](または[BBBB])の A 列の
 どの行のセルの値と比較するのか。
 
・その( A 列の)セルには「通し番号」と「番号」のどちらが入力されているのか。

 
 
ワークシート[AAAA](または[BBBB])のA列は2行目以降のセルの値と比較がしたいです。
こちらも件数により行数が異なるのですが、A列には「番号」が入力されております。
 
引用:

コピー元のセル範囲は上記の通りで本当に間違いないのか。
(その時点でどのセル(セル範囲)が選択されているかによって
 コピー元のセル範囲が変わるコードになっている)

 
コピー元のセル範囲はこちらで間違いありません。
件数がその時によって変わるためです。

回答
投稿日時: 19/05/23 15:35:36
投稿者: sk

引用:
ワークシート[AAAA](または[BBBB])のA列は2行目以降のセルの値と比較がしたいです。

引用:
こちらも件数により行数が異なるのですが、A列には「番号」が入力されております

「ワークシート[AAAA](または[BBBB])の A 列のセルを
1 行ずつ参照(≠選択)し、参照したセルの値とシート名がマッチ
(後方一致)するワークシート(の A19 セル)を貼り付け先とする
ループ処理を実行したい」ということでしょうか。
 
引用:
番号の個所は16桁の値が入ります(連番ではないランダムな値です)

・A 列内において「番号」の重複はないのか。
 
・そのブック内において、名前の末尾16桁が重複している
 ワークシートが存在するケースは発生しないのか。
("No.P1_2019052320190523" という名前のシートと
 "No.P2_2019052320190523" という名前のシートが
 同じブック内に存在している場合)
 
例として挙げられたものに限って言えば、ランダムというより
ある 2 つの日付文字列が連結されたもののように見えるのですが。

投稿日時: 19/05/23 15:51:22
投稿者: paobon

引用:

「ワークシート[AAAA](または[BBBB])の A 列のセルを
1 行ずつ参照(≠選択)し、参照したセルの値とシート名がマッチ
(後方一致)するワークシート(の A19 セル)を貼り付け先とする
ループ処理を実行したい」ということでしょうか。
 
・A 列内において「番号」の重複はないのか。
  
・そのブック内において、名前の末尾16桁が重複している
 ワークシートが存在するケースは発生しないのか。
("No.P1_2019052320190523" という名前のシートと
 "No.P2_2019052320190523" という名前のシートが
 同じブック内に存在している場合)
  
例として挙げられたものに限って言えば、ランダムというより
ある 2 つの日付文字列が連結されたもののように見えるのですが。

 
A列には同一番号が入力されております。
名前の末尾16桁が重複しているシートは存在しません。
(例としての挙げ方が分かりにくく申し訳ございません)
本来のシート名の末尾16桁はランダム値です。
 
その日により"No.P1_〜"のシートの枚数が異なるのですが
少なくとも100枚程度あり
現状は手作業でシートを探し貼付を行っている状況です。
こちらを自動化したく思っております。

回答
投稿日時: 19/05/23 17:06:33
投稿者: sk

引用:
A列には同一番号が入力されております

つまり 2 行目以降の「番号」が入力されているセルであれば、
A 列のどのセルを参照しても構わない、ということですかね。
(例えば「 A2 セルには必ず『番号』が入力されている」という前提なら、
ただ A2 セルの値のみを取得できればよい、ということになる)
 
とりあえず、以下のようなプロシージャを
そのモジュールに追加して下さい。
 
-----------------------------------------------------------------
Function FindWorksheetBySuffix(ByVal Suffix As String, _
                               Optional ByRef Book As Excel.Workbook) As String
 
    Dim ws As Excel.Worksheet
     
    If Suffix = "" Then
        Exit Function
    End If
     
    If Book Is Nothing Then
        Set Book = ActiveWorkbook
    End If
     
    For Each ws In Book.Worksheets
        If ws.Name Like ("*" & Suffix) Then
            FindWorksheetBySuffix = ws.Name
            Exit Function
        End If
    Next
     
End Function
-----------------------------------------------------------------
 
次に、下記に引用したそれぞれのコードを書き換えます。
 
引用:
If bCheck1 = True Then

Dim sKey As String
Dim sSheetName As String
 
If bCheck1 = True Then
 
引用:
Worksheets("AAAA").Activate
Range(Selection, Selection.End(xlDown)).Copy Worksheets("No.P通し番号_番号").Range("a19")
Worksheets("No.P通し番号_番号").Activate

Worksheets("AAAA").Activate
sKey = Worksheets("AAAA").Range("A2").Value
sSheetName = FindWorksheetBySuffix(sKey)
If sSheetName = "" Then
    MsgBox """" & sKey & """ とマッチするワークシートが見つかりません。", vbExclamation
Else
    Range(Selection, Selection.End(xlDown)).Copy Worksheets(sSheetName).Range("A19")
    Worksheets(sSheetName).Activate
End If
 
引用:
Worksheets("BBBB").Activate
Range(Selection, Selection.End(xlDown)).Copy Worksheets("No.P通し番号_番号").Range("a19")
Worksheets("No.P通し番号_番号").Activate

Worksheets("BBBB").Activate
sKey = Worksheets("BBBB").Range("A2").Value
sSheetName = FindWorksheetBySuffix(sKey)
If sSheetName = "" Then
    MsgBox """" & sKey & """ とマッチするワークシートが見つかりません。", vbExclamation
Else
    Range(Selection, Selection.End(xlDown)).Copy Worksheets(sSheetName).Range("A19")
    Worksheets(sSheetName).Activate
End If
 
------------------------------------------------------------
 
全体的にフローを見直した方が良いとは思いますが、
ひとまず元のコードに極力合わせる形にしました。
 
「番号」の文字数チェックなどが必要な場合は
適宜修正して下さい。

投稿日時: 19/05/24 11:04:54
投稿者: paobon

ありがとうございました。
自動化することができました。