人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

EXCEL VBAについて質問です。
参照リスト(EXCELファイル)から一行づつ値を読み込んで、マクロを実行したい。

動作としては、
?リスト.xlsの参照リストから「氏名」「ID」「PASSWORD」の値取得
※一行毎に値を取得
?取得した値を原本_ツール.xlsに反映して、マクロボタンを実行
?一人終わるごとに、原本_ツール.xlsを「名前を付けて保存」
?保存先は、デスクトップ上にある「個人ファイル」フォルダ
?保存ファイル名は、「氏名.xls」としたい
?保存が終わったら、?にもどり氏名が入っている行まで繰り返します。

補足
「リスト.xls」と「原本_ツール.xls」は、
デスクトップ上の「個人ファイル」フォルダ内にあります。

ソース付の回答でお願いします。

1363936204
●拡大する

●質問者: japan-nan
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●400ポイント ベストアンサー

まず 「原本_ツール.xls」ですが、ボタンのクリックは プライベートなので そのまま呼べません。

なので
「原本_ツール.xls」に以下のソースを 追加してください。

ボタンのあるシートに

Sub Button1_Click()
 Call CommandButton1_Click
End Sub

標準モジュールに

Sub Button_Click()
 Sheets("Sheet1").Button1_Click
End Sub


あと 実行用のエクセルですが、個人フォルダに入れてください。
つまり「リスト.xls」と「原本_ツール.xls」と同じところということです。

Sub main()
 s1 = "リスト.xls"
 s2 = "原本_ツール.xls"
 
 Workbooks.Open ThisWorkbook.Path & "\" & s1

 For a = 2 To Rows.Count
 b1 = Workbooks(s1).Sheets("Sheet1").Cells(a, "A")
 If b1 = "" Then Exit For
 
 b2 = Workbooks(s1).Sheets("Sheet1").Cells(a, "B")
 b3 = Workbooks(s1).Sheets("Sheet1").Cells(a, "C")
 
 Workbooks.Open ThisWorkbook.Path & "\" & s2
 
 Workbooks(s2).Sheets("Sheet1").Cells(2, "C") = b1
 Workbooks(s2).Sheets("Sheet1").Cells(3, "C") = b2
 Workbooks(s2).Sheets("Sheet1").Cells(4, "C") = b3
 
 Application.Run s2 & "!Button_Click"
 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls"
 Workbooks(b1 & ".xls").Close
 Next a
 
 Workbooks(s1).Close
 
End Sub

なお シート名は 画像にあるものを用いています。


きゃづみぃさんのコメント
もし オフィス2007以降で実行するならば 拡張子を xlsと指定しているため、生成されたファイルが 正しく読めない場合があります。 >|vb| その場合は、 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls" ↓ ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls", FileFormat:=xlExcel8 とします。 ||<

2 ● Hiroto
●100ポイント

質問文の動作がよく分からなかったので、勝手に変えさせていただきました。
違かったらすいません。
?ボタンを押すと、同じフォルダにあるリスト.xlsxからリストのデータを読み込む
?読み込んだデータを、原本_ツール.xlsに反映
?反映したら、同じフォルダに「(名前).xls」という名前で保存する
?保存したファイルを閉じる
?「名前」の数だけ繰り返す

※質問文に書いてあるファイル名と、画像のファイル名が違っていたので、画像の方に合わせました。

以下で動作すると思います。※先に「ボタン 1」に「Test_1」を実行するように設定しておいてください。

Sub Test_1()
Dim tSht
Dim lSht
Dim aSht
Dim lr
Dim lc
Dim x
Dim y
Dim a()

Workbooks.Open ("C:\この部分は書き換えてください\個人ファイル\リスト.xlsx")
Set tSht = ThisWorkbook.Worksheets("Sheet1")
Set lSht = Workbooks("リスト.xlsx").Worksheets("Sheet1")
lr = Range("a1").End(xlDown).Row
lc = Range("a1").End(xlToRight).Column
ReDim a(lc - 1)

For x = 2 To lr
 
 For y = 0 To lc - 1
 a(y) = lSht.Cells(x, y + 1).Value
 Next
 
 Workbooks.Add
 Set aSht = ActiveWorkbook.Worksheets("Sheet1")
 tSht.Cells.Copy (aSht.Cells)

 For y = 0 To lc - 1
 aSht.Cells(y + 2, 3).Value = a(y)
 Next
 
 ActiveWorkbook.SaveAs a(0) & ".xls", xlWorkbookNormal
 ActiveWorkbook.Close
Next

Workbooks("リスト.xlsx").Close
End Sub

このコードは、「リスト.xlsx」にあるリスト(表)が縦にも横にも伸びても、対応できるようになっていると思います。
また、「原本_ツール.xls」の最初からある表をコピーして「(氏名).xls」を作るようになっているので、表やその周りに塗りつぶしなどの書式設定をしている場合、これもコピーできると思います。


Hirotoさんのコメント
すいません。「Workbooks.Open」のところのアドレス、訂正しました。 単にファイル名ではなく、ファイルのフルネームじゃないといけないみたいです。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ