vbsで複数pptx内の文字列抽出してxls出力する処理で
1つめのpptxのopen~文字列抽出~closeはうまくいくのですが
2つめのpptxをうまくobject生成できません。
デバッグ用コメントで確認すると2つめpptxを瞬時にopen~close
したあとにForNextの文字列抽出が動いているようで
For文で"オブジェクトがありません"となってしまいます。
どなたか解決方法をご教授願えませんでしょうか。
Sub GrepPpt(objPptFile)
Dim sld,shp,rng,find_rng,tbl,find_cell
Set objPpt = CreateObject("PowerPoint.Application")
objPpt.Visible = True
Set filex = objPpt.Presentations.Open(objPptFile)
For Each sld In objPpt.ActivePresentation.Slides ←ここで
For Each shp In sld.Shapes
If shp.HasTextFrame Then
For columnx = 0 To keywordsx.Count - 1
Set rng = shp.TextFrame.TextRange
Set find_rng = rng.Find(keywordsx(columnx))
If Not find_rng Is Nothing Then
arraylstx.add rng & vbTAb & shp.Name & vbTab &～(割愛)
Exit For
End If
Next
Else ～(Table検索割愛)
End If
Next
Next
filex.Close
objPpt.Quit
Set objPpt = Nothing
End Sub
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
-------
原因をさぐるべくＦ8で確認しながら進めたところ、
「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ケタの祝日のセルをグレー&赤文字にならず、他の原因のような気もします...
--
どなたかご教示頂けましたら有難いです。
よろしくお願い致します。
