マクロ VBA入力

質問

シート1　　A　　　　B　　　C
　　　　1　コード　コード　金額
　　　　2　01
シート2　　A　　　　B　　　C　　　D　　　E
　　　　1　コード　名前　コード　名前　金額
　　　　2　01　　　　あ　　02　　　い　　20
　　　　3　01　　　　あ　　03　　　う　　30
シート1とシート2があります。シート1のA2に入力されたコードがシート2のA列に入力されていたら、その行のC列のコードをシート1のB2に反映し、E列の金額をシート1のC2に反映する。シート1のA2のコードは、シート2のA列に複数あるため、この作業を繰り返す。
シート1　A　　B　　　C
　1　コード　コード　金額　
　2　01　　　02　　　20
　3　01　　　03　　　30とできるようにするにはどうすればいいでしょうか？分かりにくい文章で申し訳ありません。関数では無理なのでVBAの入力しかないかと考えていますが、VBAは全くの初心者で困っています。どなたかご回答宜しくお願いいたします。

回答No.7

pkh4989 · ベストアンサー

こんにちは。

変更出来ます。ブック名を変更して保存するのと同じ方法で名前を変えれば、全てのシート名が違う名称で保存出来ます。
が、以下のようにするとシート名は固定「XXXXX」になります。
頑張ってくださいね。

　　 'ファイル保存処理
　　　　If wR3 > 1 Then
　　　　　　wSeq = wSeq + 1
　　　　　　wFlnm = wPath & wFlnm1 & "-" & Format(wSeq, "000")
　　　　　　Worksheets("Sheet3").Copy
　　　　　　ActiveSheet.Name = "XXXXX" '← シート名を「XXXXX」で変更
　　　　　　ActiveWorkbook.SaveAs Filename:=wFlnm
　　　　　　ActiveWorkbook.Close
　　　　End If

お礼

お返事が遅れてしまい申し訳ありませんでした。とても勉強にもなりました。本当に有難うございました。

回答No.6

pkh4989

こんにちは。

エラーになる場所(ブッククローズ)を以下のように変えてみてください。

Workbooks(wFlnm2).Close
　↓
ActiveWorkbook.Close

お礼

直してみたらできました。すごいです！本当にありがとうございました。助かりました。ちなみになんですが、この完成したシートを１枚ずつ名前を変えて保存することは可能なのでしょうか？度々申し訳ありません。でも本当にありがとうございました。とても勉強にもなりました。

回答No.5

pkh4989

こんばんは。

エラーの場所が知りたいのです。以下のように印刷処理行にカーソルを設定して、ブレークポイント設定「F9」を押してください。
実行しても、ブレークポイントで止まりますので、止まったら、「F8」を押して１行ずつ実行してみてください。
エラーになる場所が分かると思いますので、その場所とエラーメッセージを教えてください。

　　'印刷処理
　　For wI = 1 To wSeq '←この行にカーソルを設定して「F9」を押してください。
　　　　wFlnm2 = wFlnm1 & "-" & Format(wI, "000") & ".xls"
　　　　wFlnm = wPath & wFlnm2
　　　　'
　　　　Workbooks.Open Filename:=wFlnm
　　　　ActiveSheet.PrintPreview
　　　　'ActiveSheet.PrintOut
　　　　Workbooks(wFlnm2).Close
　　Next

補足

おはようございます。エラーの場所はおそらく
Workbooks(wFlnm2).Close　だったと思います。
エラーメッセージは
"実行エラー9　インデックスが有効範囲にありません"
と表示されます。

回答No.4

pkh4989

こんばんは。

シート１に検索コードを全て入れましたか？
以下のように
シート1　　A　　　　B　　　C
　　　　1　コード　コード　金額
　　　　2　01
　　　　3　02
　　　　4　03

印刷の方でエラーになりますか？
シート１で設定されたコード分作成されると思います。
その作成された分(上記の設定だと3件)を順番にオープンしながら印刷するようになっています。検証済みで問題なくオープンしながら印刷できます。
印刷の部分をプレビューに変えてみて試してみてください。

ActiveSheet.PrintOut
　↓
ActiveSheet.PrintPreview

補足

何度も何度も本当にありがとうございます。お返事が遅れてしまって申し訳ありません。私のやり方が悪いのかエラーはやはりでてしまいますが保存はされていました。また、印刷は１枚だけ実行されました。原因がわからないのでよく調べてみたいと思います。

回答No.3

pkh4989

おはようございます。

Sheet1に関索コードを全て入れてください。
後、Sheet3の印刷設定は自分でしてくださいね。

Sub 検索()
　　Dim wBuf1　　 As Variant
　　Dim wBuf2　　 As Variant
　　Dim wR1　　　　 As Long
　　Dim wR2　　　　 As Long
　　Dim wR3　　　　 As Long
　　Dim wI　　　　 As Long
　　Dim wY　　　　 As Long
　　Dim wPath　　 As String
　　Dim wFlnm1　　 As String
　　Dim wFlnm2　　 As String
　　Dim wFlnm　　 As String
　　Dim wSeq　　　　As Integer
　　'
　　Application.ScreenUpdating = False
　　With Worksheets("Sheet1")
　　　　wR1 = .Range("A" & Rows.Count).End(xlUp).Row
　　　　wBuf1 = .Range("A1:C" & wR1)
　　End With
　　With Worksheets("Sheet2")
　　　　wR2 = .Range("A" & Rows.Count).End(xlUp).Row
　　　　wBuf2 = .Range("A1:E" & wR2)
　　End With
　　'
　　'保存するフォルダ及びファイル名設定
　　wPath = ThisWorkbook.Path & "\"
　　wFlnm1 = Format(Date, "yymmdd") & "-" & Format(Time, "hhnn")
　　wSeq = 0
　　'
　　With Worksheets("Sheet3")　　 '←Sheet3へ展開します。Sheet1にするとSheet1へ展開されますが、元のデータが消えます。
　　　　For wI = 2 To wR1
　　　　　　.Cells.ClearContents
　　　　　　.Cells(1, 1) = "コード"
　　　　　　.Cells(1, 2) = "コード"
　　　　　　.Cells(1, 3) = "金額"
　　　　　　wR3 = 1
　　　　　　'
　　　　　　For wY = 2 To wR2
　　　　　　　　If wBuf2(wY, 1) = wBuf1(wI, 1) Then
　　　　　　　　　　wR3 = wR3 + 1
　　　　　　　　　　.Cells(wR3, 1) = wBuf1(wI, 1)
　　　　　　　　　　.Cells(wR3, 2) = wBuf2(wY, 3)
　　　　　　　　　　.Cells(wR3, 3) = wBuf2(wY, 5)
　　　　　　　　End If
　　　　　　Next
　　　　　　'ファイル保存処理
　　　　　　If wR3 > 1 Then
　　　　　　　　wSeq = wSeq + 1
　　　　　　　　wFlnm = wPath & wFlnm1 & "-" & Format(wSeq, "000")
　　　　　　　　Worksheets("Sheet3").Copy
　　　　　　　　ActiveWorkbook.SaveAs Filename:=wFlnm
　　　　　　　　ActiveWorkbook.Close
　　　　　　End If
　　　　Next
　　End With
　　'
　　'印刷処理
　　For wI = 1 To wSeq
　　　　wFlnm2 = wFlnm1 & "-" & Format(wI, "000") & ".xls"
　　　　wFlnm = wPath & wFlnm2
　　　　'
　　　　Workbooks.Open Filename:=wFlnm
　　　　'ActiveSheet.PrintPreview
　　　　ActiveSheet.PrintOut
　　　　Workbooks(wFlnm2).Close
　　Next
　　Application.ScreenUpdating = True
End Sub

補足

ご回答ありがとうございます。実行をするとシート３自体は完成するのですが、エラーが出て、"インデックスが有効範囲にありません"と表示されます。私の言い方が悪かった様で、すべて保存した後にフォルダの中身を一括で印刷したかったのですがうまくいきませんでした。いろいろ調べたのですがどうもよく分かりませんでした。やはりもっと勉強しなければいけませんね。

回答No.2

imogasi

VBAだけでやるほうが簡単だったかも知れないが。
ーーー
ユーザー関数を作ってやってみました。
通常の関数利用風に出来上がります。
（例データ）
Ｓｈｅｅｔ２　Ａ，Ｃ列は書式を文字列にする。
Ａ列　　Ｂ列　　Ｃ列　　Ｄ列　　Ｅ列
コード 名前 コード 名前 Ｅ金額
01 あ 01 い 20
01 あ 02 いあ 40
02 い 03 う 30
03 う 01 え 10
03 う 03 えい 20
03 05 5
02 05 15
02 06 34
04 03
ーーー
ユーザー定義関数をＶＢＡで作成（下記）
（注意）Ｓｈｅｅｔ２という名のシートに検索元シートをおくことにしているので、別の名の場合ＶＢＡのＳｈｅｅｔ２の箇所を変えてください。
ーーー
Ｓｈｅｅｔ１
Ａ１に検索するコード
Ａ２に
=IF(COUNTIF(Sheet2!$A$2:$A$100,$A$1)<ROW()-1,"",INDEX(Sheet2!$A$1:$F$100,fnd($A$1,$A$1,ROW()-1),1))
B2に
=IF(COUNTIF(Sheet2!$A$2:$A$100,$A$1)<(ROW()-1),"",INDEX(Sheet2!$A$1:$F$100,fnd($A$1,$A$1,ROW()-1),3))
Ｃ２に（最後の引数＝列指定が変わるだけ）
=IF(COUNTIF(Sheet2!$A$2:$A$100,$A$1)<(ROW()-1),"",INDEX(Sheet2!$A$1:$F$100,fnd($A$1,$A$1,ROW()-1),5))
ーー
ＶＢＥの標準モジュールに
Function fnd(a, b, c)
cl = a.Column
' MsgBox cl
d = Worksheets("Sheet2").Cells(65536, cl).End(xlUp).Row
'MsgBox d
k = 0
cn = WorksheetFunction.CountIf(Worksheets("Sheet2").Range( _
Worksheets("Sheet2").Cells(2, cl), Worksheets("Sheet2").Cells(d, cl)), b)
' MsgBox cn

For i = 1 To d
If Worksheets("Sheet2").Cells(i, cl) = b.Value Then
k = k + 1

If k > cn Then
fnd = 0
Exit Function
Else
If k = c Then
fnd = i
Exit Function
End If
End If
End If
Next i
End Function
ーーー
結果
Ｓｈｅｅｔ１のＡ１：Ｃ４
03
03 01 10
03 03 20
03 05 5

お礼

ご回答ありがとうございました。まだ勉強中なものでなかなかうまくいきませんがゆっくり時間をかけてやってみます。ありがとうございました。

回答No.1

pkh4989

こんにちは。

以下のマクロで、お試しください。
データの展開はSheet3にされますので、Sheet3を用意してください。
シートの表示形式「分類」はシート1と同様にしてください。

Sub 検索()
　　Dim wBuf1　　 As Variant
　　Dim wBuf2　　 As Variant
　　Dim wR1　　　　 As Long
　　Dim wR2　　　　 As Long
　　Dim wR3　　　　 As Long
　　Dim wI　　　　 As Long
　　Dim wY　　　　 As Long
　　'
　　Application.ScreenUpdating = False
　　With Worksheets("Sheet1") '←シート1
　　　　wR1 = .Range("A" & Rows.Count).End(xlUp).Row
　　　　wBuf1 = .Range("A1:C" & wR1)
　　End With
　　With Worksheets("Sheet2") '←シート2
　　　　wR2 = .Range("A" & Rows.Count).End(xlUp).Row
　　　　wBuf2 = .Range("A1:E" & wR2)
　　End With
　　'
　　wR3 = 1
　　With Worksheets("Sheet3")　　 '←Sheet3へ展開します。Sheet1にするとSheet1へ展開されますが、元のデータが消えます。
　　　　.Cells(1, 1) = "コード"
　　　　.Cells(1, 2) = "コード"
　　　　.Cells(1, 3) = "金額"
　　　　For wI = 2 To wR1
　　　　　　For wY = 2 To wR2
　　　　　　　　If wBuf2(wY, 1) = wBuf1(wI, 1) Then
　　　　　　　　　　wR3 = wR3 + 1
　　　　　　　　　　.Cells(wR3, 1) = wBuf1(wI, 1)
　　　　　　　　　　.Cells(wR3, 2) = wBuf2(wY, 3)
　　　　　　　　　　.Cells(wR3, 3) = wBuf2(wY, 5)
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
　　Application.ScreenUpdating = True
End Sub

補足

さっそくのご回答ありがとうございました！
一発でできました。すごいです！本当にありがとうございます。
ですが実は続きがあり、もっと欲を言えば実行が完了したシート3を保存し、今度は別のコードで実行、保存、そして保存したものを一括印刷。とゆう事を繰り返したいのです。

シート2　　A　　　　B　　　C　　　D　　　E
　　　　1　コード　名前　コード　名前　金額
　　　　2　01　　　　あ　　02　　　い　　20
　　　　3　01　　　　あ　　03　　　う　　30
　　　　4　05　　　　え　　04　　　お　　40
　　　　5　06　　　　か　　07　　　き　　50
コード01の実行が終了したらシート3を保存し最初の状態に戻します。そして、シート2の次のコード（コード05）を同様に実行し保存。今度はコード06・・・全て実行、保存が終了した後に一括で印刷・・とゆう風にする事は可能でしょうか？あまりにもわがままな質問をしてしまい申し訳ありません。初心者な為にまだまだ勉強足らずです。よろしければご回答お願いいたします。