エクセルでマクロを使った保存の方法と注意点
- エクセルでマクロを使ってHTMLファイルにデータを保存する方法を教えてもらった。 特定のセルの値をHTMLファイルに保存するマクロを作成し、ファイルを作成したディレクトリに保存する。 保存するファイルの名前は、セルの値に応じて自動的に設定される。
- 今回の質問は、エクセルでマクロを使ってHTMLファイルにデータを保存する方法を知りたいものでした。 具体的には、特定のセルの値をHTMLファイルに保存するマクロを作成し、ファイルを作成したディレクトリに保存する方法を教えてほしいという内容です。 また、保存するファイルの名前についても質問しています。
- エクセルでマクロを使ってHTMLファイルにデータを保存する方法について質問があります。 具体的には、特定のセルの値をHTMLファイルに保存するマクロの作成方法や、保存先のディレクトリの設定について質問しています。
- ベストアンサー
エクセルでマクロを使った保存の件で？
以前 エクセルのセルの中身をhtmlファイルで簡単に保存させたい？と言う質問した者です。 http://oshiete1.goo.ne.jp/qa3616400.html そこで以下のようなコードを教えてもらいました。 Sub htmlコピー() Dim c As Range Dim s As String, TmpS As String Dim myF As Integer On Error Resume Next For Each c In Range("A1").CurrentRegion.Resize(, 1) If c.Value <> "" Then s = Trim(c.Value) TmpS = Right(s, Len(s) - InStrRev(s, ".") + 1) If TmpS <> ".htm" And TmpS <> ".html" Then s = s & ".html" End If myF = FreeFile Open ThisWorkbook.Path & "\" & s For Output As #myF Print #myF, Replace(c.Offset(, 1).Value, vbLf, vbCrLf) Close #myF If Err.Number Then Err.Clear MsgBox c.Address & c.Value Exit Sub End If End If Next End Sub 今回の質問 上記の場合はhtmlファイルがエクセルのファイルと同じ場所にできます。 これを、もう1つ下の階層（フォルダを新たに作って）に入れる場合はどの辺りをいじればいいのでしょうか？
- siraku
- お礼率54% (276/508)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
＞Open ThisWorkbook.Path & "\" & s For Output As #myF の、ThisWorkbook.Path がこのワークブックのパス、 ということですね。 & は文字列を結合する演算子ですね。 ということで、 今のワークブックが C:\foo\bar.xls で、 s の中身が XXX だったら （s は対象のシートの A1 セルを取ってきてるみたいなので） C:\foo\XXX.html になってますね。 で、これを、C:\foo\sub というディレクトリを掘って、 C:\foo\sub\XXX.html として保存したいんですよね。 でしたら、 ＞Open ThisWorkbook.Path & "\sub\" & s For Output As #myF でいいんじゃないでしょうか。
関連するQ&A
- 2010 ｅｘｃｅｌ マクロ 記号の変化
エラー発生で強制終了になってしまいます。2007年のｅｘｃｅｌで作成したものですが、2010だと強制終了になってしまいます。 内容は□をダブルクリックすると■になるように作っています。 記述は2003年からのマクロ記述なので、変化が必要なのでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'セルをダブルクリックすると、・→○→△→×→・と変更する。 Dim S1 As String Dim S2 As String Dim S01 As String Dim S02 As String Dim S03 As String Dim S04 As String S1 = "□" S2 = "■" S01 = "・" S02 = "○" S03 = "△" S04 = "×" On Error GoTo ERR_12 sCheckXY S1, S2 sCheckX1234 S01, S02, S03, S04 sChangeXY S1, S2 Exit Sub ERR_12: End End Sub Sub sChangeXY(X As String, Y As String) '選択セルに□があれば■に変える Dim Str0 As String 'str1の左端 Dim Str1 As String 'strの右側更新 Dim Str2 As String 'strの左側更新 Dim Str20 As String 'strの左側一部保存 Dim L As Long Dim M As Long Dim N As Long Str1 = ActiveCell.Text L = Len(Str1) Debug.Print L If L = 0 Then End End If For N = 1 To L Debug.Print Str2 Str0 = Left(Str1, 1) If Str0 = X Or N = L Then If Str20 <> "" Then If N = L Then Str20 = Str20 + Str0 End If If MsgBox(Str20 & " はチェックしますか？", vbYesNo, "選択肢") = vbYes Then Str2 = Str2 + Replace(Str20, X, Y) Str20 = Str0 Else Str2 = Str2 + Replace(Str20, Y, X) Str20 = Str0 End If Else Str20 = Str0 End If Else Str20 = Str20 + Str0 End If Str1 = Right(Str1, L - N) Next N ActiveCell.Value = Str2 End Sub Sub sCheckXY(X As String, Y As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X Then ActiveCell.Value = Y End ElseIf ActiveCell.Text = Y Then ActiveCell.Value = X End End If End Sub Sub sCheckX1234(X1 As String, X2 As String, X3 As String, X4 As String) '選択セルがXならY,YならXにチェックをかえる If ActiveCell.Text = X1 Then ActiveCell.Value = X2 End ElseIf ActiveCell.Text = X2 Then ActiveCell.Value = X3 End ElseIf ActiveCell.Text = X3 Then ActiveCell.Value = X4 End ElseIf ActiveCell.Text = X4 Then ActiveCell.Value = X1 End End If End Sub
- ベストアンサー
- その他MS Office製品
- Excel マクロ ファイル名取得について
Excel マクロ ファイル名取得について 特定のフォルダにあるファイルのファイル名を Excelに一覧として作成します。 下記マクロで実現できたのですが、フォルダでファイルを 「詳細」で並べて上から順番にB列に反映することは 可能でしょうか。 ご回答お待ちしております。 Sub fileName() Dim MyF As String Dim myRow As Long 'ファイル名の取得 myRow = 2 MyF = Dir(ThisWorkbook.Path & "\*") If MyF <> "" Then Do Until MyF = "" Cells(myRow, "B").Value = MyF 'ファイル名 MyF = Dir() myRow = myRow + 1 Loop End If End Sub
- ベストアンサー
- その他MS Office製品
- EXCELで作ったマクロを別のファイルのEXCELでも使えるようにしたいです。
(1)EXCELファイルでマクロを作成しました。 (実際はここである人の知恵をお借りして作ったものですが…) しかし、(2)EXCELファイルで(1)EXCEL作成マクロが実行できません。 どのような処理をすれば、どのPCでも、どのファイルでも実行できるようなマクロに出来るのでしょうか？？ 以下にそのマクロを示します。 ↓↓↓ Sub 文字置換() '半角カタカナを全角に、全角英数を半角にするマクロ (Excel編） Dim rng As Range Dim Re As Object Dim myPat As String Dim c As Range Dim Matches As Object Dim Match As Object Dim Str1 As String Dim Str2 As String Dim buf As String Dim t As Long On Error Resume Next Set rng = ActiveSheet.UsedRange.SpecialCells _ (xlCellTypeConstants, xlTextValues) On Error GoTo 0 If rng Is Nothing Then MsgBox "変換する対象が見当たりません。", 48 Exit Sub End If '全角側 --- 半角側 (！-／ を加えれば記号も半角) myPat = "([\uFF66-\uFF9F]*)([！-｝]*)" '正規表現のパターン Set Re = CreateObject("VBScript.RegExp") Application.ScreenUpdating = False With Re .Global = True .IgnoreCase = True .Pattern = myPat For Each c In rng.Cells Set Matches = .Execute(c.Value) If Matches.Count > 0 Then buf = c.Value For Each Match In Matches If Len(Match.Value) > 0 Then Str1 = StrConv(Match.SubMatches(0), vbWide) If Str1 <> "" Then '0 =vbBinaryCompare buf = Replace(buf, Match.SubMatches(0), Str1, , , 0) End If Str2 = StrConv(Match.SubMatches(1), vbNarrow) If Str2 <> "" Then buf = Replace(buf, Match.SubMatches(1), Str2, , , 0) End If End If Str1 = "": Str2 = "" Next Match If buf <> c.Value Then c.Value = buf t = t + 1 End If End If Next c End With Set Re = Nothing Application.ScreenUpdating = True If t > 0 Then MsgBox t & "個のセルを変換しました。", 64 End If End Sub 出来れば、置換した文字数をメッセージBOXに表示したいです。
- 締切済み
- オフィス系ソフト
- エクセルの簡単なマクロ機能を追加したいのです
既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： Sheet2のC列に 0 があれば Sheet1のB列に 愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub
- 締切済み
- その他MS Office製品
- マクロ エクセル２００３
いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか？宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile & ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub
- 締切済み
- Excel（エクセル）
- マクロで分岐をさせる方法
下記の記録マクロでWith→End With 間にIFで分岐を試みたのですが エラーになります。どうすれば出来るのか伝授をお願いします。 マクロは初心者です。 Dim hensuh(2) As Integer Dim dekiru As Long Dim kinek As Long Dim uineu As Long Dim myTime As Date Dim flg As Boolean Sub OnTimeSamp1() Application.OnTime EarliestTime:=TimeValue("09:00:00"), Procedure:="Ontime_Set" '記録開始 Application.OnTime EarliestTime:=TimeValue("11:00:00"), Procedure:="Ontime_Reset" '記録終了 End Sub Sub Ontime_Set() 'トグルになっている If flg = False Then flg = True myTime = Now + TimeSerial(0, 0, 1) ElseIf flg = True Then flg = False Else Exit Sub End If If Range("A1").Value = "" Then Range("A1").Value = Format(Now, "hh:mm:ss") '時間記録（スタート) End If Application.OnTime EarliestTime:=myTime, _ Procedure:="my_Procedure", Schedule:=flg If flg = False Then myTime = 0 End If End Sub Sub my_Procedure() Worksheets("kirokuyou").Activate 'ワークシートをアクティブにする。（記録中別のワークシートを開けた場合そこに記録されてしまうのを防ぐ） With Range("A65536").End(xlUp).Offset(1) .Value = Format(Now, "yyyy:mm:dd:hh:mm:ss") '時間記録 .Offset(, 1).Value = Range("S3").Value 'S3 の値 .Offset(, 2).Value = Range("T3").Value 'T3 の値 .Offset(, 3).Value = Range("U3").Value 'U3 の値 .Offset(, 4).Value = Range("V3").Value 'V3 の値 dekiru = Range("V3").Value Range("V6").Value = dekiru kinek = Range("T22").Value Range("T18").Value = kinek uineu = Range("U22").Value Range("U18").Value = uineu 'IF S17 >= 120 Then 'hensuh(0) = Range("S17").Value ←変数に代入後、分岐させたいのですがエラーになる 'Elseif S17 >= 110 Then 'hensuh(1) = Range("S17").Value ←変数に代入後、分岐させたいのですがエラーになる 'Elseif S17 >= 100 Then 'hensuh(2) = Range("S17").Value ←変数に代入後、分岐させたいのですがエラーになる 'End If flg = False myTime = 0 End With Call Ontime_Set End Sub Sub Ontime_Reset() 'タイマーリセット On Error Resume Next Application.OnTime EarliestTime:=myTime, _ Procedure:="my_Procedure", Schedule:=False If Err.Number > 0 Then MsgBox "OnTime設定はされていません。", 64 Err.Clear flg = False Else MsgBox myTime & "の設定は解除されました。", 64 flg = False myTime = Empty End If End Sub
- ベストアンサー
- オフィス系ソフト
- Excelのマクロについて
文字列から数値だけを抽出するマクロを見つけたのですが、抽出するデータを選択してから実行しなければなりませんでした。 抽出するデータはAセル以下にしかないので、データを選択しないでも実行できるようにするにはどうしたら良いのでしょうか？ 宜しくお願いします。 以下見つけたマクロです。 Sub test() Dim mydata As String Dim c As Range Dim i As Integer For Each c In Selection mydata = "" For i = 1 To Len(c) If Mid(c, i, 1) >= 0 And Mid(c, i, 1) <= 9 Then mydata = mydata & Mid(c, i, 1) End If Next c.Offset(0, 1) = mydata Next End Sub
- 締切済み
- オフィス系ソフト
- エクセルで１００以上のシートからデータを読み込むのに時間がかかり困っています
エクセル２００３でAuto_Open時にデータの更新をしてみましたが、一々画面を読んでしまい時間がかかってしまいます。 まだコードがよく理解できていませんので、どなたかよい方法を教えてください。 コードは以下のようです。 シートは１８０あり、一覧表にシート名の表を作りました。 よろしくお願いします。 Sub Auto_Open() 'シートオープンで一覧表のデータ更新 '変数の宣言 Dim MyDA As Integer Dim MyDB As String Dim MyDC As String Dim MyDD As String Dim MyDE As String Dim MyDF As String Dim MyDG As String Dim MyDH As String Dim MyDI As String Dim MyDJ As String Dim MyDK As String For MyDA = 3 To 173 '一覧表を呼びシート名の代入 Worksheets("一覧表").Activate MyDB = Range("T" & MyDA).Value '必要なデータの代入 Worksheets(MyDB).Activate MyDC = Range("J3").Value MyDD = Range("J4").Value MyDE = Range("B6").Value MyDF = Range("F6").Value MyDG = Range("K6").Value MyDH = Range("C9").Value MyDI = Range("B8").Value If MyDI = "" Then MyDI = "-" End If MyDJ = Range("F8").Value If MyDJ = "" Then MyDJ = "-" End If MyDK = Range("K8").Value If MyDK = "" Then MyDK = "-" End If Sheets("一覧表").Activate Range("B" & MyDA) = MyDC Range("C" & MyDA) = MyDD Range("D" & MyDA) = MyDE Range("E" & MyDA) = MyDF Range("F" & MyDA) = MyDG Range("G" & MyDA) = MyDH Range("H" & MyDA) = MyDI Range("I" & MyDA) = MyDJ Range("J" & MyDA) = MyDK Next MyDA End Sub
- ベストアンサー
- Visual Basic
- ExcelVBA マクロの数値を２ケタに変更したい
http://www.exvba.com/blog/?p=3974 こちらの百ます計算のシートをダウンロードし活用させて頂こうと思っていますが、２ケタのものが作れるかを試してみたいと思っています。例えば26+57とか、81-32とかです。掛け算だけは、２ケタ×１ケタにしたいです。 当方プログラムが初心者でスキル不足のため、VBAがよく分かりません。以下がスクリプトのようですが、色々数値を変えてみましたがダメでした。 <--ここから--> Option Explicit '100マス計算ジェネレータ by 達人養成塾 http://www.exvba.com/ Sub main() Dim calc As Long With Application calc = .Calculation .Calculation = xlCalculationManual InputBase Range("B5"), "＋", False InputBase Range("B18"), "－", True InputBase Range("B31"), "×", False .Calculation = calc ' .Calculation = xlAutomatic End With End Sub Sub InputBase(bs As Range, op As String, bType As Boolean) With bs If Not IsEmpty(bs) Then .CurrentRegion.ClearContents End If If Not IsEmpty(.Offset(, 12)) Then .Offset(, 12).CurrentRegion.ClearContents End If SetLine bs, op, True, False SetLine bs, op, False, bType .CurrentRegion.Copy Destination:=.Offset(, 12) ExeCalc bs, op End With End Sub Private Sub SetLine(base As Range, ope As String, bRow As Boolean, add10 As Boolean) '起点セル、演算子、行か列か、値に10を足すか Dim c As Long, ar(9) As Long With base .Value = ope Application.Calculate With Worksheets("rnd") .Range("A2:B12").Sort key1:=.Range("B2"), order1:=xlAscending, Header:=xlYes For c = 3 To 12 ar(c - 3) = .Range("A" & c).Value Next End With If bRow Then For c = 1 To 10 .Offset(c).Value = ar(c - 1) Next ElseIf Not add10 Then For c = 1 To 10 .Offset(, c).Value = ar(c - 1) Next Else For c = 1 To 10 .Offset(, c).Value = ar(c - 1) + 10 Next End If End With End Sub Private Sub ExeCalc(base As Range, ope As String) Dim r As Long, c As Long With base.Offset(, 12) Select Case ope Case "＋" For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(r).Value + .Offset(, c).Value Next Next Case "－" For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(, c).Value - .Offset(r).Value Next Next Case Else For r = 1 To 10 For c = 1 To 10 .Offset(r, c).Value = .Offset(r).Value * .Offset(, c).Value Next Next End Select End With End Sub <--ここまで--> こちら他者様の著作物になりますので、もしこうした質問が不適切でしたら削除させて頂きます。 もしよろしければアドバイスを頂けましたら幸いに思います。
- ベストアンサー
- Visual Basic
お礼
ご回答ありがとうございまいした。 思っていた事ができました！