Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

17 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【82150】Re:テキストボックス

マナ - 23/5/31(水) 18:56 -


	引用なし

	パスワード

ht　tps://www.239-programing.com/cgi-bin/excelvba_bbs.cgi?id=1419

・ツリー全体表示


	【82149】Re:テキストボックス

マナ - 23/5/24(水) 16:29 -


	引用なし

	パスワード

▼ハヤップさん：

Dim txt As String

txt = "001　x　=+　4.4235mm　y　=+　2.1256mm　　z　=+ 0.1235mm"
MsgBox WorksheetFunction.Round(Val(Split(txt, "=")(1)), 2)

・ツリー全体表示


	【82148】Re:テキストボックス

ハヤップ - 23/5/24(水) 12:55 -


	引用なし

	パスワード

▼ハヤップさん：
>初めての投稿になります。ご教授宜しくお願い致します。
>ユーザーフォームテキストボックス内に
>001　x　=+　4.4235㎜　y　=+　2.1256㎜　　z　=+ 0.1235㎜
>が続けて入力されるのでxの4.42のみの値を抽出しExcelに張り付けたい場合どのような方法がありますでしょうか。
>宜しくお願い致します。

スミマセン入力不足でした。
001から始まるx,y,zの値は毎回変動します。
その際上記で書いたx 部分のみ(0.00)⬅️毎回変動　　　　　　の値のみを抽出したいです。
すみませんがご教授宜しくお願い致します。

・ツリー全体表示


	【82146】テキストボックス

ハヤップ - 23/5/23(火) 19:49 -


	引用なし

	パスワード

初めての投稿になります。ご教授宜しくお願い致します。
ユーザーフォームテキストボックス内に
001　x　=+　4.4235㎜　y　=+　2.1256㎜　　z　=+ 0.1235㎜
が続けて入力されるのでxの4.42のみの値を抽出しExcelに張り付けたい場合どのような方法がありますでしょうか。
宜しくお願い致します。

・ツリー全体表示


	【82145】Re:ユーザーフォーム内でのコマンドボタ...

ken

- 23/5/17(水) 7:16 -


	引用なし

	パスワード

▼都下さん：
返信ありがとうございます。
こんな書き方があるんですね。

今回は
タブストップ　フォレスでコマンドボタンにフォーカスが
いくようにしました。

有難う御座いました。

・ツリー全体表示


	【82144】Re:ユーザーフォーム内でのコマンドボタ...

都下 - 23/5/14(日) 17:32 -


	引用なし

	パスワード

Private Sub TextBox2_AfterUpdate()
Application.OnTime Now(), "aaaab"
End Sub

標準モジュール
Sub aaaab()
UserForm1.CommandButton2.SetFocus
End Sub

とかとか

・ツリー全体表示


	【82143】ユーザーフォーム内でのコマンドボタンへ...

ken

- 23/5/10(水) 16:40 -


	引用なし

	パスワード

いつもお世話になっております。
質問させて下さい。
ユーザーフォーム内にフレームがありその中にTextBoxとComboBoxが有ります。
ComboBoxのデフォルトの値が変更されない場合にTextBoxの値を入力したらコマンドボタンにフォーカスが移動するようにする場合はどのようなコードを書いたら良いでしょうか？

Private Sub TextBox1_AfterUpdate()

End　Sub
タブオーダーも変更してみましたが、フレーム内の為直ぐにコマンドボタンには移動しないみたいです。

何方か宜しくお願い致します。

・ツリー全体表示


	【82142】印刷プレビュー

JY - 23/4/30(日) 12:11 -


	引用なし

	パスワード

EXCELVBAで、thisworkbookから、callにてモジュールを呼び出しています。

Private Sub Workbook_Open()
Call *****
End Sub 印刷プレビューを出しているのですが、ローカルではOKなのですが、ネットワークドライブにファイルを置いて起動すると、印刷プレビューの「印刷、ズーム、プレビュー」がグレーアウトして選択できなくなります。

PrintOut Preview:=True

原因、直し方、分かる方いらっしゃいましたら、教えて下さい。
よろしくお願い致します。

・ツリー全体表示


	【82141】Re:Pasteメソッド失敗

あおこ - 23/4/5(水) 11:40 -


	引用なし

	パスワード

▼MK さん：
>↓のコードとご自身のコードをよく見比べてみてください。
>どこか違ってるとことがあります。
>
>ht　tps://daitaideit.com/vba-shapes-copy-paste/

ありがとうございました！！できました。

ご提示いただいたページも参考にしていたのですが、気付かなかったです。
「マクロの記録」で記録されたコードでは「copy」だったので・・。

ほんとうにありがとうございました。

・ツリー全体表示


	【82140】Re:Pasteメソッド失敗

MK - 23/4/4(火) 19:12 -


	引用なし

	パスワード

↓のコードとご自身のコードをよく見比べてみてください。
どこか違ってるとことがあります。

ht　tps://daitaideit.com/vba-shapes-copy-paste/

・ツリー全体表示


	【82139】Pasteメソッド失敗

あおこ - 23/4/4(火) 15:59 -


	引用なし

	パスワード

いつも参考にさせていただいています。

マクロ実行ブック内のシートの図形"Picture 1"を、別ブックのシート全てにコピペしようと下記のコードを組んでいますが、「ActiveSheet.Paste '←とまる」のところで「実行時エラー1004　Pasteメソッドが失敗しました」のエラーが出ます。

再実行するときちんと図形が貼り付けられており、また、1行ずつ実行するとエラーにならないので、コードはあっているのではないかと思うのですが・・。

解消方法がありましたら、ご教示いただけるとありがたいです。

よろしくお願いいたします。

Sub 表加工()

～宣言～
　
　Set wb1 = ThisWorkbook
　Set sh2 = wb1.Worksheets("手配表用")’コピー元シート
　　　
　Call ChangeCurPath　''カレントディレクトリをネットワーク上のパスにチェンジ　　
　　
'対象ブックを選択します
OpenFileName = Application.GetOpenFilename("Microsoft Excel ブック
,*.xls*")
　　If OpenFileName = "False" Then Exit Sub
　　　　　　
　　On Error GoTo 0
　　　　
　　'読み込み
　　 Set wb2 = Workbooks.Open(OpenFileName) 'wb2 読込元　　
　　 Application.ScreenUpdating = False　'画面表示を止める

　　 Dim WS As Worksheet
　　 For i = 1 To wb2.Worksheets.Count '全てのシートを読み込みます。
　　
　　　Set WS = wb2.Worksheets(i)
　　　　
　　　'図形コピー
　　　sh2.Activate 'マクロ実行ファイルのコピー元シート
　　　ActiveSheet.Shapes("Picture 1").Select
　　　Selection.Copy
　　　wb2.Activate 'コピー先ファイル
　　　WS.Activate
　　　WS.Range("U1").Select
　　　ActiveSheet.Paste '←とまる
　　
　　　Next i
　　
　　 wb2.Worksheets(1).Select
　　
　　 Application.ScreenUpdating = True
　　 Application.StatusBar = False
　　 MsgBox "処理が終了しました。"
　　
　　
　 End Sub

・ツリー全体表示


	【82138】Re:日付の検索

初心者 - 23/3/29(水) 16:56 -


	引用なし

	パスワード

「LookIn:=xlFormulas」する事でうまくいきました。
検討して下さった方々、ありがとうございました。

・ツリー全体表示


	【82137】日付の検索

初心者 - 23/3/29(水) 16:13 -


	引用なし

	パスワード

Sub CommandButton3_Click()

　Dim CalcDay as Date, MyRange as Range

　CalcDay = Date
　Set MyRange = Range("A:A").Find(What:=CalcDay, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
　MyRange.select

End Sub

Ａ列に日付が並んでいるワークブックにて、上記マクロにてDateがある日付のセルをSelectしたいのですが、
MyRangeはNothingのままで、Selectしてくれません。書式を変えてみましたがダメでした。

何が原因なのでしょうか？ご教示願います。

・ツリー全体表示


	【82136】Sub 条件式書式の再設定()

叱問箱 - 23/3/14(火) 6:51 -


	引用なし

	パスワード

条件式書式が設定されたセルに行を挿入したりフィルハンドルすると適用先が変わってしまいますので、マクロの自動記録で再設定できるようにしました。これに例えば10行目に一行挿入したり10行目にオートフィルをした場合に、チェンジイベントでマクロ名「Sub 条件式書式の再設定()」が自動動作するようにお願いします
チェンジイベントマクロはB列だけの5行目以降からのみに適用してください。
自動記録で取っていますのでコードが長いです
動作が同じでしたら簡略化されるとなおベストです

Sub 条件式書式の再設定()
　　Range("A5").Select
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=LEN($A5:$A2000)=1"
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 65535
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
　　Range("B5").Select
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=LEN($B5:$B2000)=1"
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 65535
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
　　Application.CutCopyMode = False
　　Cells.FormatConditions.Delete
　　Range("A5").Select
　　Range("B5").Activate
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=LEN($A5:$A2000)=1"
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 65535
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
　　Range("B5:B2000").Select
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=ISERROR(FIND(""("",$B5:$B2000,1))"
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 5296274
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
　　Range("B5:B2000").Select
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=$B5:$B2000="""""
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 49407
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
　　Range("B5:B2000").Select
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=LEN($B5:$B2000)=1"
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 65535
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
　 Range("A5:A2000").Select
　　Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
　　　　"=LEN($A5:$A2000)=1"
　　Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
　　With Selection.FormatConditions(1).Interior
　　　　.PatternColorIndex = xlAutomatic
　　　　.Color = 65535
　　　　.TintAndShade = 0
　　End With
　　Selection.FormatConditions(1).StopIfTrue = False
End Sub

Sub 一行挿入()
　　Range("B10").Select
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

Sub 一行オートフィル()
　　Selection.AutoFill Destination:=Range("A10:B10"), Type:=xlFillDefault
　　Range("A10:B10").Select
End Sub

・ツリー全体表示


	【82135】Re:カスタムリストでの並び替えについて

ken - 23/3/11(土) 10:30 -


	引用なし

	パスワード

▼マナさん：
>▼ken さん：
>
>こうでは？
>
>　　With Sheets("Sheet3").Sort
>　　　　.SortFields.Clear
>　　　　.SortFields.Add2 Key:=Range("A1"), CustomOrder:=Join(lst, ",")

有難う御座いました。
ちゃんと並び替え出来ました。
配列は今勉強をはじめたばかりなので参考になりました。
もっと勉強します。

・ツリー全体表示


	【82134】Re:カスタムリストでの並び替えについて

マナ - 23/3/10(金) 23:17 -


	引用なし

	パスワード

▼ken さん：

こうでは？

　　With Sheets("Sheet3").Sort
　　　　.SortFields.Clear
　　　　.SortFields.Add2 Key:=Range("A1"), CustomOrder:=Join(lst, ",")

・ツリー全体表示


	【82133】Re:カスタムリストでの並び替えについて

ken

- 23/3/10(金) 19:13 -


	引用なし

	パスワード

▼マナさん：
>▼ken さん：
>
>2007以降なら、これを使用するのが簡単ではありませんか。
>ht　tp://officetanaka.net/excel/vba/tips/tips189.htm

お世話になります。
リストをカスタムオーダーに入れてみましたが
エラーになってしまいます。

マクロは下記です。
Sub Sample_2()
　　Dim lst As Variant
　　With Sheets("Sheet2")
　　　　lst = WorksheetFunction.Transpose _
　　　　(Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)))
　　End With
　　With Sheets("Sheet3")
　　　　.SortFields.Clear
　　　　.SortFields.Add2 Key:=Range("A1"), CustomOrder:=lst
　　　　.SetRange Range("A1").CurrentRegion
　　　　.Header = xlYes
　　　　.Apply
　　End With
　　End Sub

・ツリー全体表示


	【82132】Re:do whileでループしないです。。。

マナ - 23/3/1(水) 20:46 -


	引用なし

	パスワード

▼れさん：

ht　tps://www.limecode.jp/entry/trap/dirindir

・ツリー全体表示


	【82131】do whileでループしないです。。。

れ

- 23/3/1(水) 20:08 -


	引用なし

	パスワード

下記コードでループせず1回で終了してしまいます。
何回見直してもわかりません、ご教授お願いできませんでしょうか。
よろしくお願いします。
対象のフォルダには3つ以上の.xlsxファイルがあります。

Sub 販売営業インセンティブへの転記()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fp As String
　　fp = ThisWorkbook.path
Dim 行先 As String
　　行先 = "C:\Users\5058\Desktop\販売営業インセンティブ"
Dim 対象 As String
　　対象 = Dir(fp & "\" & "インセンティブ" & "\" & "*.xlsx")
Do Until 対象 = ""
　　Dim 店番 As String
　　　店番 = Left(対象, 3) & "*"
　　Dim 行先フォルダ As String
　　　行先フォルダ = Dir(行先 & "\" & 店番, vbDirectory)
　　Dim FSO As Object
　　 Set FSO = CreateObject("Scripting.FileSystemObject")
　　FSO.CopyFile fp & "\" & "インセンティブ" & "\" & 対象, 行先 & "\" & 行先フォルダ & "\"
　　対象 = Dir()
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

・ツリー全体表示


	【82130】Re:カスタムリストでの並び替えについて

ken

- 23/2/28(火) 7:13 -


	引用なし

	パスワード

▼マナさん：
>▼ken さん：
>
>2007以降なら、これを使用するのが簡単ではありませんか。
>ht　tp://officetanaka.net/excel/vba/tips/tips189.htm

ご教授有難う御座います。
試してみます。

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

17 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free