VBA スケジュール表作成_連想配列で祝日設定

このQ&Aのポイント
  • VBAを使用してExcelのスケジュール表を作成する際に、連想配列を使用して祝日の設定を行いたい。しかし、祝日の曜日のセルをグレー&赤文字にすることができず、解決方法を模索している。
  • VBAを使ってExcelのスケジュール表を作成する際に、祝日の曜日のセルをグレー&赤文字にしたい。連想配列を使って祝日を管理しているが、月日が2ケタの祝日に対してうまく動作しない問題が発生している。
  • VBAを利用してExcelのスケジュール表を作成しているが、祝日のセルがうまくグレー&赤文字にならない。連想配列で祝日を管理しており、月日が2ケタの祝日に対して問題が発生している。
回答を見る
  • ベストアンサー

VBA スケジュール表作成_連想配列で祝日設定

Win10でExcelは2016を使用しています。 「西暦」をMsgBoxで指定し、スケジュール表を作成するマクロを作成中です。 日曜と祝日のセルをグレー&赤文字にさせたいので、別シートに祝日を表にしそれを連想配列に記憶させて、祝日も赤文字にさせたいのですが、下記のマクロですと祝日の曜日のセルをグレー&赤文字に出来ず行き詰っています。 ------ Sub スケジュール_日_祝_休ver() Dim ws1 As Worksheet Dim myDic As Object Dim buf As String Dim i As Integer Dim Keys() As Variant Dim ws2 As Worksheet 'シート Dim ye As Integer '年 Dim mo As Integer '月 Dim dy As Integer '日 Dim dLast As Integer '最終日 Dim r As Integer '日付書き込み列 Set myDic = CreateObject("Scripting.Dictionary") Set ws1 = Worksheets("祝日") maxRow = ws1.Range("C65536").End(xlUp).Row For i = 2 To maxRow buf = ws1.Cells(i, 3).Value 'C列のセルの値をbufに格納する If buf = "" Then '空白セルではなく ElseIf Not myDic.Exists(buf) Then '辞書にまだ登録されていなければ myDic.Add buf, 1 'そのセルの値を連想配列に登録する。 End If Next i ye = Application.InputBox("西暦を入れて下さい", Type:=1) Set ws2 = Worksheets("白紙") With ws2 r = 2 '当年1~12月 '1日の列に月を表示 For mo = 1 To 12 If mo = 1 Then .Cells(1, r) = "’" & ye & "年" & mo & "月" .Cells(1, r).Font.Bold = True .Cells(1, r).Font.Name = "HGP創英角ゴシックUB" .Cells(1, r).Font.Size = 20 Else .Cells(1, r) = mo & "月" .Cells(1, r).Font.Bold = True .Cells(1, r).Font.Name = "HGP創英角ゴシックUB" .Cells(1, r).Font.Size = 20 End If '最終日取得 dLast = Day(DateSerial(ye, mo + 1, 0)) '日にちと曜日を入れ、日・祝 のセルをグレー&赤文字 For dy = 1 To dLast .Cells(3, r) = ye & "/" & mo & "/" & dy .Cells(3, r).NumberFormatLocal = "d" .Cells(4, r) = WeekdayName(Weekday(.Cells(3, r).Value), True) Key = .Cells(3, r).Value If .Cells(4, r).Value = "日" Or .Cells(3, r).Value = myDic.Item(Key) Then '日と祝日 .Cells(4, r).Font.ColorIndex = 3 ws2.Range(Cells(5, r), Cells(73, r)).Select With Selection.Interior .ColorIndex = 15 End With End If r = r + 1 Next dy '月変わりに縦太線を引く .Range(Cells(1, r - 1), Cells(73, r - 1)).Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With Next mo End With End Sub ------- 原因をさぐるべくF8で確認しながら進めたところ、 「If .Cells(4, r).Value = "日" Or .Cells(3, r).Value = myDic.Item(Key) Then 」 のところで、.Cells(3, r).Value は「2020/1/1/」でmyDic.Item(Key)は「2020/01/01/」になっていました。 やはり、これですと同じとは認識されないのでしょうか? でも、月日が2ケタの祝日のセルをグレー&赤文字にならず、他の原因のような気もします... -- どなたかご教示頂けましたら有難いです。 よろしくお願い致します。

質問者が選んだベストアンサー

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率65% (1623/2463)
回答No.2

bufを日付として格納してください。 ElseIf Not myDic.Exists(CDate(buf)) Then '辞書にまだ登録されていなければ myDic.Add CDate(buf), CDate(buf) 'そのセルの値を連想配列に登録する。

6338-tm
質問者

お礼

kkkkkm様 ご回答ありがとうございます。 ご回答の通りに変更しましたら、希望通りになりました! マクロの完成に向けて頑張ります。 ありがとうございました。

6338-tm
質問者

補足

CD関数の事知らなかったので、自分メモとして、下記残させて頂きます。 すみません! CDate 関数は、指定した値を日付型 (Date) に変換。 文字列を日付型に変換したいときに使用。 CDate(値) 値を日付型 (Date) に変換。 引数「値」 文字列や数値を指定します。 戻り値の型 日付型 (Date)

その他の回答 (3)

  • kkkkkm
  • ベストアンサー率65% (1623/2463)
回答No.4

> object.Add key, item  ’←ここに追加? > myDic.Add CDate(buf), CDate(buf) 'その ごめんなさい説明不足でした。 Add メソッド (Dictionary オブジェクト)の構文が object.Add key, itemなので コードでは myDic.Add CDate(buf), CDate(buf) となります。 という事で、コードは最初の回答のままでお願いします。 あと、質問と関係ないところなのでまたもや蛇足なのですが maxRowとKeyの変数宣言がありませんでした。 ツール→オプションで変数宣言を強制する にしておいた方がいいかもしれません。 https://www.239-programing.com/excel-vba/basic/basic032.html

6338-tm
質問者

お礼

kkkkkm様 ご回答ありがとうございます。 そうだったんですね、承知致しました。 多々抜けているところを見直して頂いてありがとうございます。 変数宣言と強制宣言の設定を変えます。 必要なことを沢山押教えて下さりありがとうございました。

  • kkkkkm
  • ベストアンサー率65% (1623/2463)
回答No.3

No2の蛇足です。 myDic.Item(Key) keyをもとにItemを取り出しますので今回の場合Itemは同じものを指定してください。 object.Add key, item myDic.Add CDate(buf), CDate(buf) '

6338-tm
質問者

お礼

kkkkkm様 せっかく補足頂きましたのに、理解できず申し訳ありません。 つまりこういう事ですか? If buf = "" Then '空白セルではなく ElseIf Not myDic.Exists(CDate(buf)) Then '辞書にまだ登録されていなければ object.Add key, item  ’←ここに追加? myDic.Add CDate(buf), CDate(buf) 'そのセルの値を連想配列に登録する。 End If

  • unokwave
  • ベストアンサー率58% (966/1654)
回答No.1

myDic.Add buf, 1 を myDic.Add Replace(buf, "/0", "/"), 1 にして下さい。

6338-tm
質問者

お礼

unokwave様 ご回答頂きありがとうございます。 ご指摘のところを変更してみましたが、セルグレー赤文字にはなりませんでした。 申し訳ありません。

関連するQ&A

  • VBA 複数のシートをまたいでの連想配列

    win7、Excelは2013を使用しています。 添付画像の様に、12シートの合計を連想配列に格納しsheet13に書き出したいのですが、プロシージャーの下から6行目のところで、エラーコード451が出ます。 どの様に変更すれば良いか教えて下さい。 Sub 年間集計() Dim Dic Dim i As Integer Dim j As Integer Dim sh As Worksheet Dim rng As Range Dim buf As String Dim num As Integer Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Worksheets For Each rng In sh.Range("J2", sh.Cells(Rows.Count, 10).End(xlUp)) buf = rng.Value num = rng.Offset(, 1).Value If Not Dic.Exists(buf) Then Dic.Add buf, num Else Dic.Item(buf) = Dic.Item(buf) + num End If Next rng Next sh j = 2 With Worksheets("Sheet13") For i = 0 To Dic.Count - 1 .Cells(j, 1) = Dic.Keys(i)   ’エラー箇所 .Cells(j, 2) = Dic.Items(i) j = j + 1 Next i End With End Sub

  • VBA 複数シートに渡る連想配列

    Winは7、Excelは2013を使用しています。 画像の様に、シート2のA列の科目を連想配列のキーし、 シート2以降のシートのB列とC列のデータを同時に格納していきたいと思っています。 6月には、4~5月の2ヶ月分、7月には4~6月分の3ヶ月分、となるので、 シートの数だけ繰り返したいです。 それで、下記を自分で考えてみたのですが、 数々エラーになり、上手く行きません。 どなたか、ご教示頂けます様お願い致します。 Sub test_年間() '--------------------------------------- '科目を連想配列に登録し、年間集計シートに書き出す '--------------------------------------- Dim n As Integer Dim maxRow As Integer Dim Dic(36) Dim buf As String Dim Keys Dim k As Integer Dim a As Integer For s = 2 To Worksheets.Count Sheets(s).Activate maxRow = Range("A65536").End(xlUp).Row '------------------------------------ '格納 '------------------------------------ Set Dic(s) = CreateObject("Scripting.Dictionary") For n = 2 To maxRow buf = Cells(n, 1).Value 'A列のセルの値をbufに格納する b = Cells(n, 2).Value 'B列のセルの値をbに格納する c = Cells(n, 3).Value 'C列のセルの値をcに格納 If buf = "" Then '空白セルではなく ElseIf Not Dic(s).Exists(buf) Then '辞書にまだ登録されていなければ Dic(s).Add buf, b 'そのセルの値を連想配列に登録する。 'ここで Dic(S+1).Add buf, c のような事がしたいのですが.... 'でもS+1はエラーになります。 End If Next n Next s '--------------------------------------------- '書き出す '--------------------------------------------- For s = 2 To Worksheets.Count Keys = Dic(s).Keys Worksheets("年間集計").Activate With Worksheets("年間集計") k = 1 a = 1 r = 0 For n = 0 To Dic(s).Count - 1 k = k + 1 '最初の書き出しは2行目から Cells(k, 1 + r) = Keys(n) Cells(k, 2 + r) = Dic(s)(Keys(n)) ' Cells(k, 3 + r).NumberFormatLocal = "[h]:mm" ' Cells(k, 3 + r) = Dic(s + 1)(Keys(n)) r = r + 3 Next n End With Next s Set Dic(s) = Nothing MsgBox "終了" End Sub 勝手申しますが、お礼は来週月曜日なります。 どうかお許し願います。

  • ※VBA配列

    http://oshiete1.goo.ne.jp/qa5196795.htmlで 質問させてもらった者です。質問不足だったため 質問の内容を追加したかったのですが、追加の方法がわからず またこちらで質問させていただきました Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub a~tの文字が、上記のような動きをする プログラムを作成するにはどのように配列を活かせばいいですか? 配列がよくわかっておらず勉強したのですが…使えずにいます;;

  • 以下のデータがあり、これをExcel VBAの連想配列として格納したい

    以下のデータがあり、これをExcel VBAの連想配列として格納したいと考えています。 MsgBoxでキーとアイテムを表示させると表示されるのですが、 最後に一例としてExistsで確認するとFalseが返ってきます。 これは配列に格納されていないのでしょうか。 また格納されていないとすると、どうすれば格納できるのでしょうか。 A 列   B列 35   apple 37   orange 40   banana 以下がコードです。 sub test() Dim i as integer Dim myDic as Object Dim keys as Variant Set myDic = CreateObject("Scripting.Dictionary") For i = 1 to 3 myDic.Add Cells(i, 1), Cells(i, 2) Next i keys = myDic.keys For Each keys In myDic MsgBox "キー名:" & keys & vbCr & "値:" & myDic.Item(keys) Next keys MsgBox myDic.Exists(35) End Sub

  • VBA 連想配列と回数

    Widowsは7 Excelは2013を使用しています。 E列のデータの重複しないリストをK列に書きだすところまでは出来たのですが、 同じ商品名が何回出てきたをカウントしたいのですが、 下記の連想配列で一緒に出来るのか、分けて組まないといけないのか、 教えて下さい。 よろしくお願い致します。 '---------------------------- '重複しないリストをK列に書き出す '---------------------------- Dim Dic, i As Long, buf As String, Keys Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To maxRow buf = Cells(i, 5).Value 'E列のセルの値をbufに格納する If Not Dic.Exists(buf) Then '辞書にまだ登録されていなければ Dic.Add buf, buf 'そのセルの値を連想配列に登録する。 End If Next i '出力 Keys = Dic.Keys For i = 0 To Dic.Count - 1 Cells(i + 2, 11) = Keys(i) 'K2から下にリスト作成 Next i Set Dic = Nothing End Sub

  • マクロが動作しない

    Office2003にバージョンアップすると動作しないマクロが出ました。ちゃんと動作するものもあります。 内容は変更していないので内容はあってるはずですが 念のためコピーします。 Sub 電装品() Dim Gyou As Integer Dim Gyouz As Integer Dim State As Integer Dim Statez As Integer Dim CelValue As String Dim CelValuez As String Dim CopyCelNo As String Dim CopyCelNoz As String Dim WS1 As Object Dim WS2 As Object Set WS1 = Worksheets("購入品リスト") Set WS2 = Worksheets("電装品リスト") WS2.Range("A:G").Delete Shift:=xlToLeft WS2.Range("B1") = "電 装 品 リ ス ト" With WS2.Range("B1") .Font.Bold = True .Font.Italic = True .Font.Size = 24 End With WS2.Range("D1") = "作成日:" & Date WS1.Range("C3:E3").Copy (WS2.Range("A2:C2")) State = 3 For Gyou = 1 To 2000 CopyCelNo = "A" & State CelValue = WS1.Cells(Gyou, 17).Value If CelValue = "1" Then WS1.Range(WS1.Cells(Gyou, 3), WS1.Cells(Gyou, 5)).Copy (WS2.Range (CopyCelNo)) State = State + 1 End If Next WS1.Range("G3:J3").Copy (WS2.Range("D2:G2")) Statez = 3 For Gyouz = 1 To 2000 CopyCelNoz = "D" & Statez CelValuez = WS1.Cells(Gyouz, 18).Value If CelValuez = "1" Then WS1.Range(WS1.Cells(Gyouz, 7), WS1.Cells(Gyouz, 10)).Copy (WS2.Range (CopyCelNoz)) Statez = Statez + 1 End If Next End Sub

  • ファイルオープン時のマクロが一部実行されない

    いつも回答して頂き、ありがとうございます。感謝感謝です。 ファイルオープン時にApplication.Runで3つのマクロを実行させているのですが、最後のマクロだけ実行されません。どうしてでしょうか?もしかして、前の2つで『一覧シート』を除外するマクロを実行しているからでしょうか?御指導の程宜しくお願いいたします。 1番目に実行するマクロ Sub 特定のシート以外の最終履歴と次回予定日を算出する() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Integer c = 3 Do While ws.Cells(2, c).Value <> "" With ws.Cells(6, c) .FormulaR1C1 = "=MAX(R8C:R10000C)" If .Value = 0 Then .Value = "履歴無し" ws.Cells(7, c).ClearContents Else .Value = .Value ws.Cells(7, c) = DateAdd("d", ws.Cells(5, c), DateAdd("m", ws.Cells(4, c), DateAdd("yyyy", ws.Cells(3, c), ws.Cells(6, c)))) End If End With c = c + 1 Loop End If End If Next End Sub 2番目に実行するマクロ Sub 期限の未達と到達を色で分ける() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Long Dim res As Variant For c = 3 To ws.Cells(7, Columns.Count).End(xlToLeft).Column If IsDate(ws.Cells(7, c)) Then If ws.Cells(7, c) > Date Then res = 8 Else res = 3 End If Else res = xlNone End If ws.Cells(7, c).Interior.ColorIndex = res Next c End If End If Next End Sub 3番目に実行するマクロ Sub 各シートの情報を一覧へ転記する() Dim d As Integer Dim retu As Integer d = 3 Do While Cells(d, 2).Value <> "" With Worksheets(Worksheets("一覧").Cells(d, 2).Value) .Activate retu = .Range("IV7").End(xlToLeft).Column .Range(Cells(7, 3), Cells(7, retu)).Copy End With With Worksheets("一覧") .Activate Cells(d, 3).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End With d = d + 1 Loop End Sub

  • VBAで統計プログラムを作成しています。

    現在VBA(Excel)にて統計のプログラムを作成しています。 Sheet2に統計表 統計対象のシートはシートタブの色が赤色(枚数不特定) 統計表の縦軸には、B4~15に4~3(1年度の月)。横軸にはF~J4に1~5。 統計対象シートの構成は同じで セルE4に1~5の数字のどれか セルE24には1~12の数字のどれかが入ります 統計表イメージ A    B    C    D 1    1    2    3 2 4月 3 5月 4 6月 5 7月 入力画面(シート名部分赤シート) E4 ←1~5のどれか E24 ←1~12のどれか この場合において、たとえばE4が"1"、E24が"4"だった場合 統計表のB2にカウントされるというプログラムが作りたいのですが、 Option Explicit Private Sub CommandButton2_Click() Dim Ws As Worksheet Dim cnt As Variant Dim grade() As Variant 'grade = grd = 学年 grade = Array("1", "2", "3", "4", "5") Dim month() As Variant 'month = mnt = 月 month = Array("4", "5", "6", "7", "8", "9", "10", "11", "12", "1", "2", "3") Dim grd As Integer '各変数宣言 Dim mnt As Integer Dim set1 As Integer Dim set2 As Integer Dim 月ー所 As Worksheet For grd = 1 To 5 If Cells(4, 5).Value = grade(grd - 1) Then cnt = 0 set1 = grd + 5 End If For mnt = 1 To 12 If Cells(24, 5).Value = month(mnt - 1) Then set2 = mnt + 3 End If   For Each Ws In Worksheets If Ws.Tab.ColorIndex = red Then cnt = cnt + 1 End If Next Worksheets("月ー所").Cells(set2, set1).Value = cnt ←この行でエラー1004 Next mnt Next grd MsgBox "統計しました。" End Sub 矢印で示した行のエラー1004の解除方法が分からず悩んでいます どうかよろしくお願いいたします。

  • ●Excel VBA 配列●教えて下さい

    a~tの文字が順々に文字を追っていくプログラムにしたいと思い 配列を使用したのですが…プログラムが稼動しません、 下記のプログラムでは何が足りないのでしょうか わかる方いたら教えて下さい; 配列の使い方についてアドバイスがあれば そちらも教えていただきたいです…。 '――ここから―― Dim time1 As Integer, time2 As Integer, n As String Dim X As Integer, Y As Integer Dim yoko As String, tate As String Dim suuji (19) As String Sub 描画() Cells(X, Y).Value = suuji End Sub Sub 削除() Cells(X, Y).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() If yoko = "右" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 30 Then yoko = "左" ElseIf Y = 1 Then yoko = "右" End If If tate = "上" Then X = X + 1 Else X = X - 1 End If If X = 20 Then tate = "下" ElseIf X = 1 Then tate = "上" End If End Sub Sub main() suuji (0) = a suuji (1) = b suuji (2) = c suuji (3) = d suuji (4) = e suuji (5) = f suuji (6) = g suuji (7) = h suuji (8) = i suuji (9) = j suuji (10) = k suuji (11) = l suuji (12) = m suuji (13) = n suuji (14) = o suuji (15) = p suuji (16) = q suuji (17) = r suuji (18) = s suuji (19) = t For n = 0 To 19 Cells(X,Y).Value = suuji (n) Next X = 1 Y = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub '――ここまでです―― 何度も同じような質問をさせてもらってすみません;

  • エクセルファイル 行列入れ替えたもの同時作成VBA

    あるxmlファイルを一旦テキストファイルにして そこから数値をエクセルファイルに移行して ひとつはM.xlsxとし それに続いて行列を入れ替えた エクセルファイルR.xlsxを 作りたいのですが M.xlsx R.xlsxのそれぞれを作るコードを 単純に 合体させただけでは どうも できません M.xlsxだけ また R.xlsxだけの 作成するコードは 出来たのですが それぞれ別のマクロとして実行することになります ひとつのマクロでM.xlsx R.xlsx同時に 作成するVBAコードは可能でしょうか 宜しくお願い致します ちなみに該当コードを単純化して 合体したのが以下のものです win10 office10 Sub 783縦() Dim FileName As Variant ChDir "\\DESKTOP-O5\f" FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml") If FileName = False Then MsgBox "キャンセルされました" Exit Sub End If FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt" Const MyFile = "\\DESKTOP-O5\f\テキスト.txt" Const Key1 = "<Name>" Const Key2 = "</Name>" Const Key3 = "<NameKana>" Const Key4 = "</NameKana>" Const PutBokName = "M.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(2, 1).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With Const PutBokName = "R.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(1, 2).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With End Sub -------------------------------

専門家に質問してみよう