エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。

http://hatena88.web.fc2.com/hatena/newpage2.shtml

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2006/09/23 21:13:07
  • 終了:2006/09/24 04:55:23

回答(2件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982006/09/23 21:31:54

ポイント35pt

Sub Macro1()

'

' Macro1 Macro

'

' Keyboard Shortcut: Ctrl+q

'

'シート数分ループ

For a = 1 To Worksheets.Count

'シートをそのシートのK2のセルの値のファイル名で保存する。

Sheets(a).SaveAs Filename:= _

Sheets(a).Range("K2") & ".csv", FileFormat:=xlCSV, _

CreateBackup:=False

Next a

End Sub

ファイル名が だぶったりした場合は、エラーとなりますので だぶらないようにしてください。

実行すると マイドキュメントに保存されました。


http://q.hatena.ne.jp/1159013585

id:taroemon

ご回答ありがとうございます。

完璧でした。

2006/09/24 04:49:15
id:oojiji No.2

oojiji回答回数38ベストアンサー獲得回数02006/09/23 23:16:10

ポイント35pt

http://www.tekipaki.jp/~oojiji/

'メインの簡単なテストはしておりますが、チェック関数の方は

'正常ケースでのみの疎通テストしかしておりません。おまけ程度

'に考えて頂ければと思います。

Option Explicit

Const strDirName As String = "C:\はてな\" '保存するディレクトリ名(末尾「¥」付き)

Const intNameCellRow As Integer = 2 '名前の置かれているセルの行番号

Const intNameCellCol As Integer = 11 '名前の置かれているセルの列番号(K列=11列)

Sub Macro1()

'

' Macro1 Macro

' マクロ記録日 : 2006/9/23

'

Dim i As Integer 'Loop カウント用ワーク変数

Dim strSaveName As String '保存するファイル名を一次保存

'パラメータチェックを先に行う。不要ならこのIF文をコメント化してください。

If boolCheckName() = True Then

Exit Sub

End If

'全シート分ループする。

For i = 1 To Worksheets.Count

' i 番目の

Worksheets(i).Select

'k2すなわち2行11列の値を取り込む

strSaveName = Worksheets(i).Cells(intNameCellRow, intNameCellCol).Value

ActiveWorkbook.SaveAs Filename:=strDirName & strSaveName, FileFormat:=xlCSV, _

CreateBackup:=False

Next i

End Sub

'事前のエラーチェックを行う

Function boolCheckName() As Boolean

Dim strCheckName() As String

Dim i As Integer

Dim j As Integer

Dim strWork As String

'デフォルトはFalse

boolCheckName = False

'名前を保存しているセルに空白のものがあるかチェック。

For i = 1 To Worksheets.Count

'i番目のシートのファイル名値を取り込む

strWork = Worksheets(i).Cells(intNameCellRow, intNameCellCol).Value

If Trim(strWork) = "" Then

boolCheckName = True

MsgBox "空白の名称がシート名 : " & Worksheets(i).Name & "に見つかりました"

Exit Function

End If

Next i

'ファイル名に重複がないかチェック

ReDim strCheckName(Worksheets.Count + 1)

For i = 1 To Worksheets.Count

'i番目のシートのファイル名値を取り込む

strWork = Worksheets(i).Cells(intNameCellRow, intNameCellCol).Value

For j = 1 To i - 1

If strWork = Worksheets(j).Cells(intNameCellRow, intNameCellCol).Value Then

boolCheckName = True

MsgBox "空白の名称がシート名 : " & Worksheets(i).Name & " と " _

& Worksheets(i).Name & " に重複があります "

Exit Function

End If

Next j

Next i

End Function

id:taroemon

ご回答ありがとうございます。

さっそく試してみます。

2006/09/24 04:54:25

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

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

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

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

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