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

解決済みの質問

マクロ 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は全くの初心者で困っています。どなたかご回答宜しくお願いいたします。

  

投稿日時 - 2007-07-12 15:37:52

QNo.3161330

すぐに回答ほしいです

質問者が選んだベストアンサー

こんにちは。

変更出来ます。ブック名を変更して保存するのと同じ方法で名前を変えれば、全てのシート名が違う名称で保存出来ます。
が、以下のようにするとシート名は固定「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

投稿日時 - 2007-07-21 17:14:50

お礼

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

投稿日時 - 2007-07-24 15:58:03

ANo.7

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

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

回答(7)

ANo.6

こんにちは。

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

Workbooks(wFlnm2).Close
 ↓
ActiveWorkbook.Close

投稿日時 - 2007-07-19 15:06:25

お礼

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

投稿日時 - 2007-07-20 18:02:16

ANo.5

こんばんは。

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

  '印刷処理
  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

投稿日時 - 2007-07-17 21:24:57

補足

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

投稿日時 - 2007-07-18 11:43:46

ANo.4

こんばんは。

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

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

ActiveSheet.PrintOut
 ↓
ActiveSheet.PrintPreview

投稿日時 - 2007-07-13 21:03:51

補足

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

投稿日時 - 2007-07-17 15:14:22

ANo.3

おはようございます。

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

投稿日時 - 2007-07-13 10:23:02

補足

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

投稿日時 - 2007-07-13 20:11:16

ANo.2

VBAだけでやるほうが簡単だったかも知れないが。
ーーー
ユーザー関数を作ってやってみました。
通常の関数利用風に出来上がります。
(例データ)
Sheet2 A,C列は書式を文字列にする。
A列  B列  C列  D列  E列
コード名前コード名前E金額
01あ01い20
01あ02いあ40
02い03う30
03う01え10
03う03えい20
03055
020515
020634
0403
ーーー
ユーザー定義関数をVBAで作成(下記)
(注意)Sheet2という名のシートに検索元シートをおくことにしているので、別の名の場合VBAのSheet2の箇所を変えてください。
ーーー
Sheet1
A1に検索するコード
A2に
=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))
C2に(最後の引数=列指定が変わるだけ)
=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))
ーー
VBEの標準モジュールに
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
ーーー
結果
Sheet1のA1:C4
03
030110
030320
03055

投稿日時 - 2007-07-12 19:06:02

お礼

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

投稿日時 - 2007-07-13 18:31:17

ANo.1

こんにちは。

以下のマクロで、お試しください。
データの展開は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

投稿日時 - 2007-07-12 16:43:12

補足

さっそくのご回答ありがとうございました!
一発でできました。すごいです!本当にありがとうございます。
ですが実は続きがあり、もっと欲を言えば実行が完了したシート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・・・全て実行、保存が終了した後に一括で印刷・・とゆう風にする事は可能でしょうか?あまりにもわがままな質問をしてしまい申し訳ありません。初心者な為にまだまだ勉強足らずです。よろしければご回答お願いいたします。

投稿日時 - 2007-07-12 17:21:56

あなたにオススメの質問