1363936204 EXCEL VBAについて質問です。

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

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

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

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/03/22 16:10:04
  • 終了:2013/03/25 21:13:53

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13481ベストアンサー獲得回数11982013/03/22 17:25:41

ポイント400pt

まず 「原本_ツール.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

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

id:taknt

もし オフィス2007以降で実行するならば 拡張子を xlsと指定しているため、生成されたファイルが 正しく読めない場合があります。

その場合は、
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls" 

↓
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls", FileFormat:=xlExcel8 

とします。
2013/03/22 19:47:06

その他の回答(1件)

id:taknt No.1

きゃづみぃ回答回数13481ベストアンサー獲得回数11982013/03/22 17:25:41ここでベストアンサー

ポイント400pt

まず 「原本_ツール.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

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

id:taknt

もし オフィス2007以降で実行するならば 拡張子を xlsと指定しているため、生成されたファイルが 正しく読めない場合があります。

その場合は、
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls" 

↓
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & b1 & ".xls", FileFormat:=xlExcel8 

とします。
2013/03/22 19:47:06
id:hiroto300 No.2

Hiroto回答回数356ベストアンサー獲得回数1002013/03/22 19:36:12

ポイント100pt

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

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

  • リスト.xlsx
  • 原本_ツール.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」を作るようになっているので、表やその周りに塗りつぶしなどの書式設定をしている場合、これもコピーできると思います。

id:hiroto300

すいません。「Workbooks.Open」のところのアドレス、訂正しました。

単にファイル名ではなく、ファイルのフルネームじゃないといけないみたいです。

2013/03/22 22:20:48

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません