Sub 表からワイルド()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim ws5 As Worksheet
Dim ARPU1 As String
Dim ARPU2 As String
Dim i As Long
Dim j As Long
Dim trgStr As String
Dim myAry As Variant
Set ws1 = Sheets("貼付")
Set ws2 = Sheets("設定")
Set ws3 = Sheets("抽出")
Set ws4 = Sheets("画像")
Set ws5 = Sheets("集計")
myAry = ws1.Cells(1, 1).CurrentRegion
ARPU1 = "*" & ws2.Cells(2, 5) & "*"
ARPU2 = "*" & ws2.Cells(2, 6) & "*"
For i = 1 To UBound(myAry)
If myAry(i, 1) Like "*, *" Then trgStr = myAry(i, 1)
If myAry(i, 1) Like ARPU1 Then
j = ws3.Cells(Rows.Count, 3).End(xlUp).Row + 1
ws3.Cells(j, 3) = trgStr
End If
Next i
For i = 1 To UBound(myAry)
If myAry(i, 1) Like "*, *" Then trgStr = myAry(i, 1)
If myAry(i, 1) Like ARPU2 Then
j = ws3.Cells(Rows.Count, 3).End(xlUp).Row + 1
ws3.Cells(j, 3) = trgStr
End If
Next i
End Sub
Sub タイトルの両隣に画像を貼る()
Dim ws1 As Worksheet
Dim ws4 As Worksheet
Set ws1 = Sheets("貼付")
Set ws4 = Sheets("画像")
Dim shname As Variant
Dim title As Range
shname = Array(ws4.Range("B3"), ws4.Range("B4"), ws4.Range("B5"))
' シンスタの処理 ～繰り返し１
ws4.Shapes(shname(0)).Copy ' 画像をコピー
Set title = ws1.Range("E7")
Call タイトル画像(ws1, title) ' セルE7に貼り付ける。画像をセルの大きさに合わせる
Set title = ws1.Range("I7")
Call タイトル画像(ws1, title) ' セルI7に貼り付ける。画像をセルの大きさに合わせる
' 迷惑の処理 ～繰り返し２
ws4.Shapes(shname(1)).Copy ' 画像をコピー
Set title = ws1.Range("L7")
Call タイトル画像(ws1, title) ' セルE7に貼り付ける。画像をセルの大きさに合わせる
Set title = ws1.Range("P7")
Call タイトル画像(ws1, title) ' セルI7に貼り付ける。画像をセルの大きさに合わせる
' D+の処理 ～繰り返し３
ws4.Shapes(shname(2)).Copy ' 画像をコピー
Set title = ws1.Range("S7")
Call タイトル画像(ws1, title) ' セルE7に貼り付ける。画像をセルの大きさに合わせる
Set title = ws1.Range("W7")
Call タイトル画像(ws1, title) ' セルI7に貼り付ける。画像をセルの大きさに合わせる
' クリップボードをクリア
Application.CutCopyMode = False
End Sub