VBA 別ファイルの空白行を探す

質問

すみません、よろしくお願いいたします。

＜前提＞
Aファイル・・貼り付け元（マクロを組み込んでいるのはこちら）
xファイル・・貼り付け先（ファイル名が一定ではない・シートは1つでシート名は固定）

＜質問内容＞
Aファイル、ｘファイルともに開き、
AファイルのデータをｘファイルのA:B列（結合している）の空白行へ
貼り付けという作業をしたいと思っています。

ｘファイルの名前がかわってしまうので、
どちらのファイルも開いていて、
この二つのファイル以外は開いていないという前提で、
Windows(2).Activate
でxファイルを指定するところまではできたのですが、
（教えてgooで教えていただきました）
ｘファイルのA:B列の空白行を探して貼り付けというのを
どうVBAで記述したらいいのかわかりません。

すみませんが、わかるかたお願いいたします。

回答No.7

Wendy02 · ベストアンサー

こんばんは。

作ってみたところ、一箇所見えていない部分がありました。

貼り付け先のA:Bが、連結しているということですから、
コピー元のシートのRange("B6:L" & RowNum02)　　B6:C6 が、連結していないと、エラーが発生してしまいます。
それに対処する方法はまだ考えていません。

まだ、テスト段階ですから、うまくいかないかもしれません。とりあえず、試験してみてください。

'-------------------------------------------------------------------------
'=========================================
'*****　ユーザー設定　*****
Private Const PSW As String = "password1234"　'パスワード
Private Const mCOMPANY As String = "株式会社AAA"　'会社名
Private Const mFILENAME As String = "20*" '先頭に20が付くファイル
'=========================================
Sub CopyProTest3()
　　Dim DataNum01 As Long
　　Dim RowNum02 As Long
　　Dim CopyRange09 As Range
　　'-------------------------------------------
　　Dim wb As Object
　　Dim i As Long
　　Dim dstWb As Workbook

　　For Each wb In Workbooks
　　　　If wb.Name Like mFILENAME Then
　　　　　　Set dstWb = wb
　　　　　　i = i + 1
　　　　End If
　　Next
　　If i = 0 Then
　　　　MsgBox "該当ブックが開いていません。", vbInformation, mCOMPANY
　　　　Exit Sub
　　ElseIf i = 1 Then
　　　　If MsgBox("貼り付け先のファイルを開いていますか？よければOKボタンで実行してください。", vbOKCancel, "株式会社AAA") = vbNo Then
　　　　　　MsgBox "キャンセルしました！！", vbInformation, mCOMPANY
　　　　　　Exit Sub
　　　　End If
　　ElseIf i > 1 Then
　　　　MsgBox "該当ブックが2つ以上開いています。", vbInformation, mCOMPANY
　　　　Exit Sub
　　End If
　　'-------------------------------------------
　　With ThisWorkbook.ActiveSheet
　　　　.Unprotect Password:=PSW
　　　　.Protect Password:=PSW, UserInterfaceOnly:=True

　　　　'P2には入力のデータの件数が表示されるようにしてます。
　　　　DataNum01 = .Range("P2").Value
　　　　'何行目までデータが入力されているか表示されています。１つ目のデータはA6からL6まで入力するのですが、２つデータが入っていたら、7行目になるのでここには7と数字が表示されます。
　　　　RowNum02 = Val(.Range("O2").Value) '数値認識させる

　　　　If RowNum02 <= 5 Then
　　　　　　MsgBox "入力されていません。処理を中止します。", vbInformation + vbOKOnly, mCOMPANY
　　　　　　Exit Sub
　　　　End If
　　　　'データが数式のため、貼り付け先ファイルの都合上、いったんこのファイル上で、値としてコピーしております。
　　　　'.Range("D6:M81").Value = .Range("D6:M81").Value

　　　　.Range("B2").Value = "確定済"
　　　　.Range("P2").Value = 1
　　　　'コピーするのはB6～L列の入力されている行までです。
　　　　Set CopyRange09 = .Range("B6:L" & RowNum02)
　　End With

　　On Error Resume Next
　　With dstWb.Worksheets(1)
　　　　CopyRange09.Copy
　　　　.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
　　　　Application.CutCopyMode = False
　　　　Application.Goto .Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　Set CopyRange09 = Nothing
　　If Err.Number > 0 Then
　　　 MsgBox Err.Number & ": " & Err.Description, vbExclamation
　　End If
　　End With
　　On Error GoTo 0
End Sub

'-------------------------------------------

お礼

Wendy02さま
本当に本当にありがとうございます！おかげで完成することができました！Wendy02さんの記述をもとにもっと色々勉強していきたいと思います！
こんなに時間をかけて相談に乗っていただき、感謝の言葉がもう見つかりません!本当に助かりました、ありがとうございました！！

2010年がWendy02さまにとって良い年になりますように☆（＾人＾）祈るくらいしかできませんが、感謝の気持ちでいっぱいです。

monnmonn20

回答No.6

Wendy02

遅くなりました。

書き換えてみました。もともと、2日前から、こういうスタイルを考えていたのですが、質問要件から外れるダメ出しされることが多いのでやめたのでした。

これは、該当ファイルがひとつ開いて入れは、他のファイルを開いていても、コピーされます。ほとんどの問題は起こりません。元のブックから起動すれば良いです。もし、失敗したら、エラーメッセージを出すようにしました。

起動する場合は、CommandButton でも、ショートカットでも可能です。

'-------------------------------------------
Sub CopyPro02()
　　Dim wb As Workbook
　　Dim dstWb As Workbook
　　Dim i As Long
'-------------------------------------------
　　'*****[ユーザー設定]*****
　　Const NAMEINI As String = "20*" 'ファイル名の先頭
　　Const COPYRANGE As String = "A1:A10" 'コピー範囲
'-------------------------------------------
　　For Each wb In Application.Workbooks
　　　　If wb.Windows(1).Visible And wb.Name Like NAMEINI Then
　　　　　 Set dstWb = wb
　　　　　　i = i + 1
　　　　End If
　　Next wb
　　If i > 1 Then
　　　　MsgBox "コピー先の該当ブックが2つ以上開いています。" & vbCrLf & _
　　　　"コピー先は、一つだけにしてください。", vbExclamation
　　　　Exit Sub
　　End If
　　On Error Resume Next

　　ThisWorkbook.Worksheets("Sheet1").Range(COPYRANGE).Copy _
　　dstWb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　Application.Goto dstWb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　If Err.Number > 0 Then
　　　　MsgBox Err.Number & ": " & Err.Description
　　Else
　　　　MsgBox "コピーは正しくされました。", vbInformation
　　End If
　　On Error GoTo 0
　　Set dstWb = Nothing
End Sub

お礼

すみません、2回同じものがはいってしまいました。

Range("D6:M81").Select　から
↓
Selection.FormulaHidden = True　までです。

お恥ずかしいです。

補足

Wendy02さん
ありがとうございます、２日前から、こういうスタイルを考えていたのですね、、すごいです。今回初めてBVAを使ったのですが、私には全く思いつきもしませんでした。手探り状態でWendy02さんにはとても助けられています。ありがとうございます。

すみません、上記を実行してみたのですが、1004：アプリケーション定義またはオブジェクト定義のエラーと出てしまいました。
コピーの仕方がまずいのかしらと思ったのですが、もうすでに私が見てもどこかにエラーがあるのかどうかもわかりません（汗）すみませんが、おわかりでしたらお教えください。

あと、お見せするのも恥ずかしいのですが、コピー元のデータに結構面倒なマクロを組んでいます。

貼り付け先のファイルの指定方法を教えてもらったら自分で組み合わせようと思っていたのですが、Wendy02さんに記述いただいた内容に、もうどう組み合わせていいのかわかりません・・。すみません。Wendy02さんがいらっしゃらなかったらあきらめていたかもしれません。。

以下、コピー元のコピー部分のマクロです。

Dim mon01 As Long
Dim mon02 As Long
Dim mon09 As String
Dim mon11 As Long
Dim mon99 As String
Dim mon100 As String

mon01 = Range("P2").Value　'P2には入力のデータの件数が表示されるようにしてます。
mon02 = Range("o2").Value　'何行目までデータが入力されているか表示されています。１つ目のデータはA6からL6まで入力するのですが、２つデータが入っていたら、7行目になるのでここには7と数字が表示されます。

mon11 = Range("o2").Value

If mon11 <= 5 Then

MsgBox "入力されていません。処理を中止します。", vbOKOnly, "株式会社AAA"
Exit Sub

End If

mon99 = MsgBox("貼り付け先のファイルを開いていますか？よければOKボタンで実行してください。", vbYesNo, "株式会社AAA") 'Yes = 6 No = 7

If mon99 = 7 Then
MsgBox "キャンセルしました！！", vbOKOnly, "株式会社AAA"

Exit Sub

End If

ActiveSheet.Unprotect Password:="password1234"

Range("D6:M81").Select　'データが数式のため、貼り付け先ファイルの都合上、いったんこのファイル上で、値としてコピーしております。
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A6:M81").Select
Selection.Locked = True
Selection.FormulaHidden = True

Range("B2").Select
ActiveCell.FormulaR1C1 = "確定済"

Range("P2").Select
ActiveCell.FormulaR1C1 = 1

Range("D6:M81").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A6:M81").Select
Selection.Locked = True
Selection.FormulaHidden = True

Range("P2").Select
ActiveCell.FormulaR1C1 = 1

mon09 = ("B6:L" & mon02)　'コピーするのはB6～L列の入力されている行までです。

Range(mon09).Select
Selection.Copy

わたしのこんなたどたどしい記述でわかりますでしょうか？
色々とすみません、もしよければよろしくお願いいたします。

回答No.5

Wendy02

あとひとつ、この部分を確認させてください。

#名称「20*」のファイルがひとつだけなら、シートさえ特定できれば、そのままコピーできます。
と書いたように、シートは特定できますか？

シートを特定できないと、目的のシートを必ず開いてもらわなくてはならなくなります。

#シートのタブの順番が左端にあるものは、いつでも、Worksheets(1) となります。

というスタイルで良いのでしょうか？

>私は2007で作成しているのですが、97-2003verで保存しても作動するようにしたいなと思っています。

分かりました。なお、私は、Excel 97は、注意する点は分かっているつもりですが、今は、97をインストールしていませんので、動作確認できません。2007で作成したものは、一旦、2003で保存し動作確認した後に、配布したほうがよいです。上位にも下位(2000まで）は問題なく動きます。

お礼

すみません！できました！！

ありがとうございます！
Wendy02さんにはなんてお礼をいったらいいかわかりません！
お時間をかけてご相談いただきほんとうにありがとうございました。

お礼のしようがなく申し訳ないです、本当に助かりました。ありがとう
ございます！

※ほかに記載する場所がなかったので、こちらから失礼いたします。

補足

Wendy02さま

貼り付け先のシートは1つだけで、シート名はsheet１ではないのですが、固定されています。
Excel97で使用の人はさすがにいないとはおもうので、大丈夫かと思います。
いろいろと考えてくださってありがとうございます、頼もしいです。

回答No.4

Wendy02

こんにちは。

>記述いただいた内容で実行できたのですが、これですと貼り付け先ファイルでマクロを実行しなければならなくなってしまうのですが、コピー元ファイルで実行できるようにって可能ですか？

私の懸念したひとつです。昨日、アップロードした時点で、いくつかの方法は考えてコードも書いていたのですが、質問要件からは外れるので、やめました。なお、念のため、マクロが組み込まれるExcelのバージョンを教えてください。

本当は、名称「20*」のファイルがひとつだけなら、シートさえ特定できれば、そのままコピーできます。だから、貼り付けるシートが分かればよいのですが。たとえば、シートのタブの順番が左端にあるものは、いつでも、Worksheets(1) となります。

補足

気にかけていただいてありがとうございます。

Excelのバージョンですが、私は2007で作成しているのですが、97-2003verで保存しても作動するようにしたいなと思っています。

「20*」のファイルを一つだけ開いた状態にするというのを周知させるのは可能かと思います。マクロを実行したときに、メッセージボックスに注意文を表示するようにしようかと思っています。

すみません、よろしくお願いいたします。

回答No.3

Wendy02

こんばんは。

#2の補足を取り入れてみましたが、作ってみると、不足している部分があるように思います。それは、貼り付ける側のシートには、もしかしたら、タイトル行のA1などに、識別する文字がものがあるのではないでしょうか？

もしそうなら、
　ThisWorkbook.Worksheets("Sheet1").Range("A1:A10").Copy _

この行の手前に、たとえば、
If ActiveSheet.Cells(1, 1).Value Like "名前" Then
とか入れれば、より確実に失敗が少なくなります。

ただ、これでも、他人に配るものとしては、不安が残ります。これを実行するためには、CommandButton にするとか、メニューに入れるとか、そこまで考えないといけないです。

'-------------------------------------------

Sub CopyPro01()
　　If WindowsCount > 2 Then
　　　　MsgBox "ブックが3つ以上開いています。" & vbCrLf & _
　　　　"コピーするブックと貼り付けるブックだけにして、貼り付けるシートをアクティブにしてください。", vbExclamation
　　　　Exit Sub
　　End If
　　If ActiveSheet.Parent.Name <> ThisWorkbook.Name Then
　　　　If StrConv(ActiveSheet.Parent.Name, vbNarrow) Like "20*" Then
　　　　　　ThisWorkbook.Worksheets("Sheet1").Range("A1:A10").Copy _
　　　　　　ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　Else
　　　　　　MsgBox "そのブックのシートは違います。確認してください。", vbExclamation
　　　　End If
　　Else
　　　　MsgBox "元のブックにはコピーできません。" & vbCrLf & _
　　　　"貼り付けされる側のブックのシートをアクティブにしてください。", vbExclamation
　　End If
End Sub
'
Function WindowsCount() As Integer
'ブックをカウントする関数プロシージャ
Dim wb As Workbook
Dim i As Long
　For Each wb In Application.Workbooks
　　 If wb.Windows(1).Visible Then
　　　　i = i + 1
　　 End If
　Next wb
　WindowsCount = i
End Function

補足

ありがとうございます！
現在、貼り付け先ファイルのA3：A4（結合）にタイトルがありA1とA2にもデータが入力されています。

記述いただいた内容で実行できたのですが、これですと貼り付け先ファイルでマクロを実行しなければならなくなってしまうのですが、コピー元ファイルで実行できるようにって可能ですか？

Wendy02さんに頼りっぱなしですみません・・もうちょっとお勉強します、でもいま急ぎなのでとても助かります。

回答No.2

Wendy02

こんにちは。

まず、前回の「フォルダごと、色々な人へ配る予定なので、できればアクティブなファイルという指定をしたい。」という条件では、もう少しきちんと作る必要があると思います。とても、「この二つのファイル以外は開いていない」という前提を、他人の環境まで延長できるわけがありません。もし、そうしたいのでしたら、そういうオブションをつけなくてはなりません。

Windowsコレクションは、可視、不可視、二重のWindowに関わらず、開かれた順番であって、Workbook自体を指定するものではありません。仮に、8割、9割問題がないといっても、分かる問題はつぶしておいたほうが良いです。

「A:B列の空白行を探して」というものは、そのまま行ったら、A列はB列に準じますから、A:B列の空白でしたら、特別の指定がない限りは、A列の空白を探すことになります。

例：マクロのない側のブックのActiveSheet のA列の空白セルを探すコード
'-------------------------------------------
Sub Test1()
If ActiveSheet.Parent.Name <> ThisWorkbook.Name Then
　ThisWorkbook.Worksheets("Sheet1").Range("A1:A10").Copy _
　　　ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Else
　MsgBox "元のブックにはコピーできません。", vbExclamation
End If
End Sub

'-------------------------------------------

補足

Wendy02さま
ありがとうございます、もしよければTest1の記述内容を説明していただけるとうれしいです。

「元のブックにコピーできない」という設定は大変ありがたいです。
コピーマクロを実行する際に、注意メッセージボックスを出すのですが、そのまま実行するとおっしゃる通り、開いた順番が違えば元ファイルに貼りつける可能性もあるかもしれません。

貼り付け先のファイル名には必ず頭に「20」がつくのですがワイルドカードを使って指定しようとしても、うまくできません。

もしもおわかりでしたら、
●開いているファイルで頭に「20」のつくファイルのA列空白行を探して貼り付け。見つからない場合・複数の場合はエラーメッセージ。

というのは可能でしょうか？

回答No.1

MackyNo1

以下のようなコードでA列の一番下のセルを選択することができます。

Range("A65536").End(xlUp).Offset(1, 0).Select

＃ご自分でこのようなコードを作りたいなら、Ctrl+↓または↑キーのショートカット操作で最終セルを選択し、「相対参照」ボタンを押して、１つ下のセルを選択する手順をマクロの記録で実行すれば、同様の操作をするコードを取得することができます。

補足

ありがとうございます、実行してみたところ、空白行を取得できました！