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

エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。
http://hatena88.web.fc2.com/hatena/newpage2.shtml

●質問者: taroemon
●カテゴリ:コンピュータ
✍キーワード:VBA エクセル マクロ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●35ポイント

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

◎質問者からの返答

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

完璧でした。


2 ● oojiji
●35ポイント

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

◎質問者からの返答

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

さっそく試してみます。

関連質問


●質問をもっと探す●



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