[[20231012154558]]　『VBAワイルドカード置き換え』（さんさん）　ページの最後に飛ぶ

『VBAワイルドカード置き換え』（さんさん）

どうしても解決できず、ご教授ください。
よろしくおねがいいたします。

■やりたい事
PPTの数ページに2023/11/1 - 2023/11/12（右の日付部分は可変）の記載があり右の日付部分を昨日に置き換えたいです。
例　昨日が11/30の場合、2023/11/1 - 2023/11/30

下記コードの★1でワイルドカードが効いていないのか、★2でリプレイスされていないようです。PPTにまったく変化がありません。

■コード

Sub Powerpoint_Cal()

  Dim ppApp As New PowerPoint.Application
  Dim ppPrs As PowerPoint.Presentation
  ppApp.Visible = True
'  Set ppPrs = ppApp.Presentations.Open("G:\共有ドライブ\PJ_GIN#7_REPORT\02_Report Data\DailyReport_GIN.pptx")
  Set ppPrs = ppApp.Presentations.Open("C:\temp\test\DailyReport_GIN.pptx")
'  ppPres.LinkFormat.Update

    'Dim sld As Slide
    'Dim shp As Object
    'Dim orgStr As String
    'Dim ystStr As String
    'Dim rplStr As String
    'Dim tmpTxt As String
    'orgStr = "yyyy/mm/dd"
    'ystStr = "2023/10/3"
    '
    'For Each sld In ppPrs.Slides
    '    For Each shp In sld.Shapes
    '        If shp.HasTextFrame Then
    '           tmpTxt = shp.TextFrame.TextRange.Text
    '           tmpTxt = Replace(tmpTxt, orgStr, ystStr)
    '           shp.TextFrame.TextRange.Text = tmpTxt
    '        End If
    '    Next
    'Next

    Dim sld As Slide
    Dim shp As Object
    Dim orgStr As String
    Dim ystStr As String
    Dim tmpTxt As String
    Dim ystDate As Date
    Dim strDate As String
    orgStr = "2023/11/01*" '★1
    ystDate = DateAdd("d", -1, Date)
    strDate = Format(ystDate, "yyyy/m/d")
    ystStr = "2023/11/01 - " & strDate

    For Each sld In ppPrs.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                tmpTxt = shp.TextFrame.TextRange.Text
                tmpTxt = Replace(tmpTxt, orgStr, ystStr) '★2
                shp.TextFrame.TextRange.Text = tmpTxt
            End If
        Next
    Next
'    'ファイルのPDF化
'    Dim filePath As String
'    Dim fileName As String
'    Dim a As Long
'
'    With ppPrs
'       ' 階層が上のエクスポートするファイルの保存先を指定
'        filePath = .Path
'        a = InStrRev(filePath, "\") - 1
'        filePath = Left(filePath, a)
'        fileName = "DailyReport_GIN.pdf"
'        '指定の場所にPDFファイルを保存
'        .Export filePath & "\test02\" & fileName, "PDF"
''        .Save
'    End With

End Sub

＜使用 Excel：Microsoft365、使用 OS：Windows11 ＞

　VBA の Replace 関数って、ワイルドカード使えないでしょ。
　じゃあどうするかは、今日はもう時間がないので、きっと誰かがフォローしてくれるだろう。
（xlg） 2023/10/12(木) 16:07:48

 日付のスタートとエンドで形式が違うのですか？
 "yyyy/m/d"　で正しいのですか？
 または、2023/11/1　ではないんですか？

 正規表現というのを使うとできそうですけど、大げさかな。

（xyz） 2023/10/12(木) 17:45:10

失礼しました。。日付はスタートとエンドどちらも形式は同じでyyyy/mm/ddです。正規表現は初めて聞きました。少し調べてみますm(__)m
（さんさん） 2023/10/12(木) 18:07:16

横からですが何点か。

■１
コメントアウトしている部分や冗長と思える部分を整理してみると↓のようになるとおもいますが、わざわざ【ExcelVBA】でパワーポイントをいじくるのに理由はあるのですか？
別にできないことではないですが、餅は餅屋じゃないかなとおもいます。

    Sub 整理()
        Dim ppApp As New PowerPoint.Application
        Dim ppPrs As PowerPoint.Presentation
        Dim sld As Slide, shp As Object
        Dim ystStr As String, tmpTxt As String

        Set ppPrs = ppApp.Presentations.Open("C:\temp\test\DailyReport_GIN.pptx")

        For Each sld In ppPrs.Slides
            For Each shp In sld.Shapes
                If shp.HasTextFrame Then
                    ystStr = "2023/11/01 - " & Format(DateAdd("d", -1, Date), "yyyy/m/d")
                    tmpTxt = Replace(shp.TextFrame.TextRange.Text, "2023/11/01*", ystStr)
                    shp.TextFrame.TextRange.Text = tmpTxt
                End If
            Next
        Next
    End Sub

■２
Replaceメソッドであれば、ワイルドカードが使えそうな気がしますが、PowerPointVBAはよくわからないので代替案など。

    Sub 代替案()
        Dim ppApp As New PowerPoint.Application
        Dim ppPrs As PowerPoint.Presentation
        Dim sld As Slide, shp As Object
        Dim ystStr As String, tmpTxt As String

        Set ppPrs = ppApp.Presentations.Open("C:\temp\test\DailyReport_GIN.pptx")

        For Each sld In ppPrs.Slides
            For Each shp In sld.Shapes
                If shp.HasTextFrame Then
                    ystStr = "2023/11/01 - " & Format(DateAdd("d", -1, Date), "yyyy/m/d")
                    If shp.TextFrame.TextRange.Text Like "2023/11/01*" Then
                        Stop 'ブレークポイントの代わり
                        shp.TextFrame.TextRange.Text = ystStr
                    End If
                End If
            Next
        Next
    End Sub

（もこな２） 2023/10/12(木) 18:21:24

 > 少し調べてみます
 ミスリードした模様です。please stop your study.

 既に解決済みであれば不要ですが、そうでなければ、
 いくつか例を挙げてもらうとよいかもしれません。
 そのスライドのshapeにある文字列は、結構短いものですか？

（xyz） 2023/10/12(木) 19:36:33

もこな2さん、xyzさん、ありがとうございます。

＞わざわざ【ExcelVBA】でパワーポイントをいじくるのに理由はあるのですか？
省きましたが、上部にエクセルデータを加工するコードを書いてます。

■全作業プロセス
エクセル元データをVBAで加工→リンク貼り付けしてあるPPTを更新および日付変更

＞そのスライドのshapeにある文字列は、結構短いものですか？
PPTの数ページに下記のような文字列があり、yyyy/mm/dd（実際は可変の日付）の箇所だけ変更したいです。
: DWH（個人）
: 2023/11/01 – yyyy/mm/dd
: スマホ総販（SIM含む）+単体加入
: CN

■頂いた代替案で修正しました。★1部分までいきますが、その下がスルーされます。。やはりワイルドカードの部分で検索できていないように思います。

■全コード
Option Explicit
Sub Jisseki()

    fname = Application.GetOpenFilename
    If fname <> False Then Range("D5") = fname
End Sub
Sub Activation()
    Call Excel_Cal
    Call Powerpoint_Cal
End Sub
'Sub Excel_Cal()
'    Dim wbThis As Workbook, dstWB As Workbook
'    Dim dstSH01 As Worksheet, dstSH02 As Worksheet, dstSH03 As Worksheet
'    Dim intN As Integer
'
'    Application.ScreenUpdating = False
'    Application.DisplayAlerts = False
'
'    Set wbThis = ThisWorkbook
'    '実績ファイル設定
'    Set dstWB = Workbooks.Open(wbThis.Worksheets("VBA起動ボタン").Cells(5, "D").Value)
'    'すべて更新
'    dstWB.RefreshAll
'
'    Set dstSH01 = dstWB.Worksheets("実績")
'    Set dstSH02 = dstWB.Worksheets("実績(加入率)")
'    Set dstSH03 = dstWB.Worksheets("実績(加入数)")
'
'    '日付覧生成
'    Dim N As Long, tmpR As Long, Days As Long, cnt As Long
'    Dim lastDay As Date, ystDay As Date
'    'テーブルデータの最終日を取得
'    With dstSH01
'        With .Range("A3").ListObject.ListColumns(1).DataBodyRange
'            lastDay = .Cells(.Rows.Count, 1).Value
'        End With
'        'テーブルデータ最終日から昨日差分を計算
'        ystDay = DateAdd("d", -1, Date)
'        Days = ystDay - lastDay
'        tmpR = .Cells(Rows.Count, "B").End(xlUp).Row + 1
'        If IsDate(Format(lastDay, "yyyy/mm/dd")) Then
'            With .Range("A3").ListObject
'                N = .ListColumns(1).Range.Count
'                For i = N + 1 To N + Days
'                    lastDay = lastDay + 1
'                    .ListColumns(1).Range(i) = Format(lastDay, "yyyy/mm/dd")
'                    cnt = cnt + 1
'                Next i
'            End With
'        End If
'        '他実績シートに日付を貼り付け
'        If Days <> 0 Then
'            .Range(.Cells(tmpR, "A"), .Cells(tmpR + cnt - 1, "A")).Copy Destination:=dstSH02.Cells(tmpR, "A")
'            .Range(.Cells(tmpR, "A"), .Cells(tmpR + cnt - 1, "A")).Copy Destination:=dstSH03.Cells(tmpR, "A")
'        End If
'    End With
'
'    '前のデータを値張り
'    Dim tmpR02 As Long
'    If Days <> 0 Then
'        With dstSH01
'            tmpR02 = .Cells(Rows.Count, "A").End(xlUp).Row - 1
'            .Range(.Cells(4, "A"), .Cells(tmpR02, "BC")).Value = .Range(.Cells(4, "A"), .Cells(tmpR02, "BC")).Value
'        End With
'        With dstSH02
'           .Range(.Cells(4, "A"), .Cells(tmpR02, "O")).Value = .Range(.Cells(4, "A"), .Cells(tmpR02, "O")).Value
'        End With
'        With dstSH03
'           .Range(.Cells(4, "A"), .Cells(tmpR02, "P")).Value = .Range(.Cells(4, "A"), .Cells(tmpR02, "P")).Value
'        End With
'    End If
'    Application.ScreenUpdating = True
'    Application.DisplayAlerts = True
'End Sub

Sub Powerpoint_Cal()

    Dim ppApp As New PowerPoint.Application
    Dim ppPrs As PowerPoint.Presentation
    ppApp.Visible = True
    '  Set ppPrs = ppApp.Presentations.Open("G:\共有ドライブ\PJ_GIN#7_REPORT\02_Report Data\DailyReport_GIN.pptx")
    Set ppPrs = ppApp.Presentations.Open("C:\temp\test\DailyReport_GIN.pptx")
    '  ppPres.LinkFormat.Update

    Dim sld As Slide
    Dim shp As Object
    Dim ystStr As String
    Dim tmpTxt As String

    For Each sld In ppPrs.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                ystStr = "2023/11/01 - " & Format(DateAdd("d", -1, Date), "yyyy/m/d")
                If shp.TextFrame.TextRange.Text Like "2023/11/01*" Then '★1
                    Stop 'ブレークポイントの代わり
                    shp.TextFrame.TextRange.Text = ystStr
                End If
            End If
        Next
    Next

' 'ファイルのPDF化
' Dim filePath As String
' Dim fileName As String
' Dim a As Long
'
' With ppPrs
' ' 階層が上のエクスポートするファイルの保存先を指定
' filePath = .Path
' a = InStrRev(filePath, "\") - 1
' filePath = Left(filePath, a)
' fileName = "DailyReport_GIN.pdf"
' '指定の場所にPDFファイルを保存
' .Export filePath & "\test02\" & fileName, "PDF"
'' .Save
' End With
（さんさん） 2023/10/13(金) 10:20:35

＞エンドサブ、サブPowerpoint_Cal()
横着者ですね。
（???） 2023/10/13(金) 10:37:00

　全コードはよいけど、なんで要らんコメントアウトされた行までしかも大量に貼り付けるかなぁ。
（｀ー´ ） 2023/10/13(金) 11:00:03

　★1 にブレークポイント設定してステップ実行で確認すべし！

　確認を容易にするために、1 枚目のスライドの最初の Shape（たぶんタイトル）を一時的に "2023/11/01 - xxxx" に変えてみることをおすすめします。
（xlg） 2023/10/13(金) 11:06:00

xlgさん、ありがとうございます。
上記方法で試してみますm(__)m
（さんさん） 2023/10/13(金) 11:17:20

  参考にしてください。
    Dim s     As String
    Dim ary
    Dim k     As Long
    s = shp.TextFrame.TextRange.Text
    If InStr(s, "2023/11/01") > 0 Then
        ary = Split(s, vbLf)
        For k = 0 To UBound(ary)
            If InStr(ary(k), "2023/11/01") > 0 Then
                ary(k) = ": 2023/11/01 - " & Format(Date - 1, "yyyy/mm/dd")
                Exit For
            End If
        Next
        shp.TextFrame.TextRange.Text = Join(ary, vbLf)
    End If

（xyz） 2023/10/13(金) 11:20:10

 >PPTの数ページに下記のような文字列があり
 それは4つの例であって、それぞれは一行のデータなら、もっと単純なコードになりますね。

 そのほか、そちらで確認・対応して欲しい点。
 ・複数行だとしたときの改行コード。
 ・"-" の文字コード。ChrW(8211)を使って修正文字列を構成するとよいと思います。
（xyz） 2023/10/13(金) 11:46:29

コメント返信：

[ 一覧(最新更新順) ]

[[20231012154558]] 『VBAワイルドカード置き換え』（さんさん） ページの最後に飛ぶ

[[20231012154558]]　『VBAワイルドカード置き換え』（さんさん）　ページの最後に飛ぶ