VBAなんでも質問スレ Part2 [転載禁止]©2ch.net

[過去ﾛｸﾞ] VBAなんでも質問スレ Part2 [転載禁止]©2ch.net (1002ﾚｽ)
上下前次1-新
通常表示 512ﾊﾞｲﾄ分割ﾚｽ栞
抽出解除ﾚｽ栞

このｽﾚｯﾄﾞは過去ﾛｸﾞ倉庫に格納されています｡
次ｽﾚ検索歴削→次ｽﾚ栞削→次ｽﾚ過去ﾛｸﾞﾒﾆｭｰ

ﾘﾛｰﾄﾞ規制です｡10分ほどで解除するので､他のﾌﾞﾗｳｻﾞへ避難してください｡

272: デフォルトの名無しさん [sage] 2017/02/26(日) 14:44:16.79 ID:nMuhJunv

エクセルのマクロでも質問大丈夫でしょうか？
名前と同じファイル名の画像を名前セルの隣に貼り付けるプログラムなんですが
Sub ボタン1_Click()
Const n As Long = 2
Dim i As Long
Dim x As Double
Dim s As String
Dim t As FileDialog
Dim m As VbMsgBoxResult
With ActiveSheet
For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row Step 6
Set r = .Cells(i, 3).MergeArea
s = "D:\画像\1\" & .Cells(i, 2).Value & ".jpg"
Dir Application.Path
With .Pictures.Insert(s).ShapeRange
.LockAspectRatio = msoTrue
x = Application.Min(r.Width / .Width, (r.Height - n) / .Height)
.Width = .Width * x
.Left = r.Left + (r.Width - .Width) / 2
.Top = r.Top + (r.Height - .Height) / 2
End With
Next
End With
End Sub
この"D:\画像\1\"の部分をフォルダ選択できるようにしたいので
Dim s As String
　　Dim t As FileDialog
Set t = Application.FileDialog(msoFileDialogFolderPicker)
s = "t" & .Cells(i, 2).Value & ".jpg"
としたら「1004　PicturesクラスのInsertプロパティを取得できません。」と実行できません
どうしたら"D:\画像\1\"の部分をフォルダ選択できるようにできるのでしょうか？ご教示お願い致します。

http://mevius.5ch.net/test/read.cgi/tech/1432173164/272

993: デフォルトの名無しさん [sage] 2021/08/25(水) 17:34:31.79 ID:qYcBJ8fd

おっきした
>>990を↓に修正
Function MakeText(text As String, rightChar As String, leftChar As String) As String
Dim startPosition As Integer
Dim endPosition As Integer
Dim InstrStartPosition As Integer
InstrStartPosition = 1
Do While InStr(InstrStartPosition, text, rightChar) <> 0
startPosition = InStr(InstrStartPosition, text, rightChar)
If startPosition <> 0 Then
endPosition = InStr(startPosition + 1, text, leftChar)
End If
Dim midText As String
midText = Mid(text, startPosition, endPosition - startPosition + 1)
Dim midTextChanged As String
midTextChanged = Replace(midText, vbLf, "")
text = Replace(text, midText, midTextChanged)

InstrStartPosition = startPosition + Len(midTextChanged)
MsgBox "無限ループになっちゃった時はctrl + Breakを押せ" & vbCrLf & vbCrLf & text

Dim textForCheck As String
If textForCheck = text Then
MakeText = text
Exit Function
End If
textForCheck = text

Loop
MakeText = text
End Function

http://mevius.5ch.net/test/read.cgi/tech/1432173164/993

上下前次1-新書関写板覧索設栞歴

ｽﾚ情報赤ﾚｽ抽出画像ﾚｽ抽出歴の未読ｽﾚ

ぬこの手ぬこTOP 0.042s