Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
83 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【80814】Re:十字キーで色をつけたセルの移動の方法
質問  ＳＨＵＮ  - 19/5/16(木) 20:20 -
引用なし
パスワード
   亀マスターさん
ご回答ありがとうございます。
初心者につき、変数の取得、というのがよくわかっていませんが、色々ググって以下のように修正してみました。
が、”ユーザー定義型が定義されていません”というエラーがでます。
なぜでしょうか？
---
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As LongLong

Sub 練習()

Dim i As Integer

Dim j As Integer


　　i = 10
　　j = 10
　　
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　Do
　　　　If GetAsyncKeyState(37) <> 0 Then
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　j = j - 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　End If
　　　　
　　　　If GetAsyncKeyState(38) <> 0 Then
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　i = i - 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　End If
　　　　
　　　　If GetAsyncKeyState(39) <> 0 Then
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　j = j + 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　End If
　　　　
　　　　If GetAsyncKeyState(40) <> 0 Then
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　i = i + 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　End If
　　　　
　　　　If GetAsyncKeyState(13) <> 0 Then
　　　　
　　　　Exit Do
　　　　
　　　　End If
　　　　
　　Loop
　　

End Sub

---

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

▼亀マスター さん：
>この手のプログラムを組むときは、次のようにループ処理で実現します。
>
>Do
>
>　　'押しているキーを取得
>
>　　'キーコードに応じた動作
>
>　　'ループを抜けるための処理
>
>Loop
>
>現在提示されたコードで問題なのは、
>１．ループしていないのでプログラム中で1回キーコードを判定したら終了する
>２．そもそも入力状況が取得できていない（？）
>
>入力状況の取得方法はいくつかありますが、Windows APIを使うのがわかりやすいと思います。
>ht tps://excel-excel.com/tips/vba_305.html
>
>なお、注意点として、ループ中にループを抜けるためのコードを入れておいてください。でないと、無限ループで終わらなくなります。
>ループを抜ける方法は何でもいいですが、エスケープキーが押されたら抜けるというのがよく見られます。
>If 【エスケープキーが押されている】 Then Exit Do
>という感じにすればいいでしょう。
>
>あと、VBEの設定で「変数の宣言を強制する」にチェックを入れておいた方がいいですよ。
>これを入れておくと、コード中に「Option Explicit」が自動で入り、未定義の変数を使用するとエラーが発生してわかるようになりますが、変数を強制しない状態はバグの温床になります。
>実際、
>Select Case keycode
>の「keycode」って、どこにも宣言してませんよね？
・ツリー全体表示
【80813】Re:十字キーで色をつけたセルの移動の方法
回答  亀マスター  - 19/5/16(木) 19:35 -
引用なし
パスワード
   この手のプログラムを組むときは、次のようにループ処理で実現します。

Do

　　'押しているキーを取得

　　'キーコードに応じた動作

　　'ループを抜けるための処理

Loop

現在提示されたコードで問題なのは、
１．ループしていないのでプログラム中で1回キーコードを判定したら終了する
２．そもそも入力状況が取得できていない（？）

入力状況の取得方法はいくつかありますが、Windows APIを使うのがわかりやすいと思います。
ht tps://excel-excel.com/tips/vba_305.html

なお、注意点として、ループ中にループを抜けるためのコードを入れておいてください。でないと、無限ループで終わらなくなります。
ループを抜ける方法は何でもいいですが、エスケープキーが押されたら抜けるというのがよく見られます。
If 【エスケープキーが押されている】 Then Exit Do
という感じにすればいいでしょう。

あと、VBEの設定で「変数の宣言を強制する」にチェックを入れておいた方がいいですよ。
これを入れておくと、コード中に「Option Explicit」が自動で入り、未定義の変数を使用するとエラーが発生してわかるようになりますが、変数を強制しない状態はバグの温床になります。
実際、
Select Case keycode
の「keycode」って、どこにも宣言してませんよね？
・ツリー全体表示
【80812】十字キーで色をつけたセルの移動の方法
質問  ＳＨＵＮ  - 19/5/16(木) 18:40 -
引用なし
パスワード
   ＶＢＡ初心者です。

初期位置に黄色で色をつけたセルを、十字キーで押すことにより
移動させるプログラムを組みたいです。（簡単なゲームの自機の操作みたいなイメージです）

以下自作ソースになります。

---

Sub 練習()

Dim i As Integer

Dim j As Integer


　　i = 10
　　j = 10
　　
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　Select Case keycode
　　　　Case vbKeyLeft
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　j = j - 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　Case vbKeyUp
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　i = i - 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　Case vbKeyRight
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　j = j + 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　　　Case vbKeyDown
　　　　
　　　　Cells(i, j).Interior.ColorIndex = xlNone
　　　　i = i + 1
　　　　Cells(i, j).Interior.ColorIndex = 6
　　　　
　　End Select


End Sub

---

初期場所(10,10)を黄色に塗って、例えば左を押したら(10,10)を無色にして
(9,10)に黄色をつけるイメージで作成しましたが、何の反応もありません。

ご教授よろしくお願いいたします。
・ツリー全体表示
【80811】Re:フォルダ内のファイル名の変更につい...
回答  γ  - 19/5/16(木) 7:35 -
引用なし
パスワード
   変更後の名前である
myfile.ParentFolder.Path & "\" & Mid(myfile.Name, InStr(myfile.Name, "☆☆") + 2, 8) & "_" & myfile.Name
について、それぞれの文字列要素
myfile.ParentFolder.Path
Mid(myfile.Name, InStr(myfile.Name, "☆☆") + 2, 8)
myfile.Name
がどのような内容か、ご自分で観察する必要があるのではないですか？
デバッグ手法をおさらいしてください。
・ツリー全体表示
【80810】フォルダ内のファイル名の変更についてで...
質問  チマ  - 19/5/16(木) 6:44 -
引用なし
パスワード
   フォルダ内のファイル名の変更が必要になって次のようなマクロを作成しました

Sub ファイル名変更()
Dim fso As New FileSystemObject
Dim myfile As file
For Each myfile In fso.GetFolder("F:\新しいフォルダー").Files
　 If InStr(myfile.Name, "☆☆") <> 0 Then
　　 fso.MoveFile myfile, myfile.ParentFolder.Path & "\" & Mid(myfile.Name, InStr(myfile.Name, "☆☆") + 2, 8) & "_" & myfile.Name
　 End If
Next myfile

End Sub

"F:\新しいフォルダー"の中には
"F:\新しいフォルダー\1234567☆☆1234567891.pdf"
"F:\新しいフォルダー\1234567☆☆12345678912.pdf"
の２つのファイルがありますがマクロの実行結果は

"F:\新しいフォルダー\12345678_12345678_1234567☆☆1234567891.pdf"
"F:\新しいフォルダー\12345678_12345678_1234567☆☆12345678912.pdf"
と書き換わってしまいます。

私はそれぞれ
"F:\新しいフォルダー\12345678_1234567☆☆1234567891.pdf"
"F:\新しいフォルダー\12345678_1234567☆☆12345678912.pdf"
とファイル名を変更したいのですがfor each　next　で余分にループして思っているファイル名に変更できません。

　いろいろ調べましたがどうしてもわからないので教えてください。
　
・ツリー全体表示
【80809】Re:エラー時のスキップ処理について
お礼  Hiroshi  - 19/5/15(水) 15:44 -
引用なし
パスワード
   ピンクさん

ありがとうございます。

　完璧です。思い通りの作動でした。当初内容が激変していたので戸惑いましたが
アプローチ方法は一つではないと勉強になりました。
・ツリー全体表示
【80808】Re:エラー時のスキップ処理について
発言  ピンク  - 19/5/15(水) 11:35 -
引用なし
パスワード
   ▼Hiroshi さん：
Sub シート選択()
　　Dim strSN() As String
　　Dim i As Long, j As Long, k As Long
　　
　　For i = 1 To 100
　　　　For j = 2 To 6 Step 2
　　　　　　If ActiveSheet.Cells(i, j).Value <> "" Then
　　　　　　　　k = k + 1
　　　　　　　　ReDim Preserve strSN(1 To k) As String
　　　　　　　　strSN(k) = ActiveSheet.Cells(i, j).Value
　　　　　　End If
　　　　Next j
　　　　Worksheets(strSN).PrintOut
　　　　Erase strSN
　　　　k = 0
　　Next i
End Sub
・ツリー全体表示
【80807】エラー時のスキップ処理について
質問  Hiroshi  - 19/5/15(水) 10:09 -
引用なし
パスワード
   お世話になります。

　それぞれのセルにハイパーリンクを設定してシートをセット印刷するマクロを組んだのですが、「Ｄ」若しくは「Ｆ」の先がない場合があり、その際にその行そのものを印刷せずに次行へスキップしてしまいます。
　
　これを「Ｂ、Ｄ」若しくは「Ｂ、Ｆ」の組み合わせで印刷するようにしたいのですが、エラー処理、if構文、スキップ等試したのですが上手く動作しませんでした。ご教授いただきたいのでよろしくお願い致します。


Sub シート選択()

　　Dim strSN(1 To 3) As String
　　Dim i As Long
　　
　　On Error Resume Next
　　
　　For i = 1 To 100
　　
　　strSN(1) = ActiveSheet.Range("B" & i).Value
　　strSN(2) = ActiveSheet.Range("D" & i).Value
　　strSN(3) = ActiveSheet.Range("F" & i).Value
　　
　　Worksheets(strSN).PrintOut
　　
　　Next i
　　　
End Sub
・ツリー全体表示
【80806】Re:複数のセルに入れた数字のワードシー...
お礼  サル  - 19/5/15(水) 9:32 -
引用なし
パスワード
   マナさん

ご返信いただきありがとうございます。
又、お礼が遅くなり申し訳ありません。

当方、VBAはいまだ始めたばかなので、非常に助かります。

重ねてどうもありがとうございます。
・ツリー全体表示
【80805】Re:Excelの新元号対応(?)で、ExcelVBAに...
発言  マナ  - 19/5/14(火) 18:58 -
引用なし
パスワード
   ▼令和で困り者 さん：

>まだ不明な点がありますので、その時はまたお願いいたします。

解決したからといって、マルチポスト先を放置しないほうがよいです。
誰も回答してくれなくなりますよ。
・ツリー全体表示
【80804】Re:Excelの新元号対応(?)で、ExcelVBAに...
お礼  令和で困り者  - 19/5/14(火) 17:53 -
引用なし
パスワード
   ピンクさま

いろいろお手数をおかけしました。
お礼申し上げます!!
まだ不明な点がありますので、その時はまたお願いいたします。


▼ピンク さん：
>▼令和で困り者 さん：　　
>　　strBuff = Replace(strDate, "年", "/")
>　　s = InStr(strBuff, "/")
>　　strBuff = Replace(strBuff, "月", "/")
>　　strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"
>　　If s = 3 Then
>　　　　strBuff = Mid(strBuff, 1, 2) + 1988 & Mid(strBuff, 3, 6)
>　　ElseIf s = 2 Then
>　　　　strBuff = Mid(strBuff, 1, 1) + 2018 & Mid(strBuff, 2, 6)
>　　End If
>
>あなたの記述は
>　Elself
>正解は
>　ElseIf
・ツリー全体表示
【80803】Re:Excelの新元号対応(?)で、ExcelVBAに...
発言  ピンク  - 19/5/14(火) 17:30 -
引用なし
パスワード
   ▼令和で困り者 さん：　　
　　strBuff = Replace(strDate, "年", "/")
　　s = InStr(strBuff, "/")
　　strBuff = Replace(strBuff, "月", "/")
　　strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"
　　If s = 3 Then
　　　　strBuff = Mid(strBuff, 1, 2) + 1988 & Mid(strBuff, 3, 6)
　　ElseIf s = 2 Then
　　　　strBuff = Mid(strBuff, 1, 1) + 2018 & Mid(strBuff, 2, 6)
　　End If

あなたの記述は
　Elself
正解は
　ElseIf
・ツリー全体表示
【80802】Re:Excelの新元号対応(?)で、ExcelVBAに...
質問  令和で困り者  - 19/5/14(火) 14:06 -
引用なし
パスワード
   ▼ピンク 様：

以下のようでよろしいでしょうか？

「Elself s = 2 Then」でコンパイルエラー(修正候補：ステートメントの最後)が表示されてしまいます...


　　strBuff = Replace(strDate, "年", "/")
　　s = InStr(strBuff, "/")
　　strBuff = Replace(strBuff, "月", "/")
　　strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"
　　If s = 3 Then
　　strBuff = Mid(strBuff, 1, 2) + 1988 & Mid(strBuff, 3, 6)
　　Elself s = 2 Then
　　strBuff = Mid(strBuff, 1, 1) + 2018 & Mid(strBuff, 2, 6)
End If

　　With ActiveWorkbook.Sheets(strDate).Tab
　　　　.Color = dblColor(intI)
　　　　.TintAndShade = 0
　　End With

End Sub


>▼令和で困り者 さん：
>strBuff = Replace(strDate, "年", "/")
>s = InStr(strBuff, "/")
>strBuff = Replace(strBuff, "月", "/")
>strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"
>If s = 3 Then
>　　strBuff = Mid(strBuff, 1, 2) + 1988 & Mid(strBuff, 3, 6)
>ElseIf s = 2 Then
>　　strBuff = Mid(strBuff, 1, 1) + 2018 & Mid(strBuff, 2, 6)
>End If
・ツリー全体表示
【80801】Re:Excelの新元号対応(?)で、ExcelVBAに...
発言  ピンク  - 19/5/14(火) 11:17 -
引用なし
パスワード
   ▼令和で困り者 さん：
strBuff = Replace(strDate, "年", "/")
s = InStr(strBuff, "/")
strBuff = Replace(strBuff, "月", "/")
strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"
If s = 3 Then
　　strBuff = Mid(strBuff, 1, 2) + 1988 & Mid(strBuff, 3, 6)
ElseIf s = 2 Then
　　strBuff = Mid(strBuff, 1, 1) + 2018 & Mid(strBuff, 2, 6)
End If
・ツリー全体表示
【80800】Re:Excelの新元号対応(?)で、ExcelVBAに...
質問  令和で困り者  - 19/5/14(火) 9:19 -
引用なし
パスワード
   マナ様

ご連絡ありがとうございます。
始めからで申し訳ありませんが、お教え頂きました以下の
９行を何処に差し込めばいいのでしょうか？
よろしくお願いいたします。


▼マナ さん：
>▼令和で困り者 さん：
>
>２年以上前は無視して良いなら
>
>Sub test()
>　　Dim shn As String
>　　
>　　shn = "1年5月"
>
>　　If Val(shn) > 29 Then
>　　　　MsgBox Format("H" & shn, "yyyy/mm/01")
>　　Else
>　　　　MsgBox Format("R" & shn, "yyyy/mm/01")
>　　End If
>　　
>End Sub
・ツリー全体表示
【80799】Re:データを別アプリに再入力する方法
お礼  たる  - 19/5/13(月) 21:51 -
引用なし
パスワード
   ▼マナ さん：
>▼たる さん：
>
>ご要望のことは不可能です。


了解です。お答えいただきありがとうございました。
・ツリー全体表示
【80798】Re:データを別アプリに再入力する方法
発言  マナ  - 19/5/13(月) 19:33 -
引用なし
パスワード
   ▼たる さん：

ご要望のことは不可能です。
・ツリー全体表示
【80797】Re:Excelの新元号対応(?)で、ExcelVBAに...
発言  マナ  - 19/5/13(月) 19:30 -
引用なし
パスワード
   ▼令和で困り者 さん：

２年以上前は無視して良いなら

Sub test()
　　Dim shn As String
　　
　　shn = "1年5月"

　　If Val(shn) > 29 Then
　　　　MsgBox Format("H" & shn, "yyyy/mm/01")
　　Else
　　　　MsgBox Format("R" & shn, "yyyy/mm/01")
　　End If
　　
End Sub
・ツリー全体表示
【80796】Excelの新元号対応(?)で、ExcelVBAにバグ...
質問  令和で困り者  - 19/5/13(月) 17:19 -
引用なし
パスワード
   MS-Offceを新元号対応にしたところ、前任者が作成した年間スケジュール(Excel VBA)に
次のエラーが発生しました。

Sheet名[３１年４月]までは正常でしたが、Sheet[１年５月]を作り掛けると
「実行時エラー'13'　型が一致しません」となり
「 intI = CInt(Mid(strBuff, 1, 2)) + 1988」行が黄色となります。

また、以下１行目の「/」を外すと、Sheet[１年９月]まで作成後、同様のエラー表示になります。
（桁数が問題かと色々探して見てみましたが...）

解決方法のご教示をお願いできれば助かります。


strBuff = Replace(strDate, "年", "/")　　　　　　　　　---->strDate "１年５月"　strbuff ""　　　　　 int:10
strBuff = Replace(strBuff, "月", "/")　　　　　　　　　---->strDate "１年５月"　strbuff "１/５月"　　int:10
strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"　　　---->strDate "１年５月"　strbuff "１/５/"　　 int:10
intI = CInt(Mid(strBuff, 1, 2)) + 1988　　　　　　　　 ---->strDate "１年５月"　strbuff "1/5/01"　　 int:10
strBuff = CStr(intI) & Mid(strBuff, 3, 6)


ちなみにSheet名[３１年４月]の場合は以下のようになります。

strBuff = Replace(strDate, "年", "/")　　　　　　　　　---->strDate "３１年４月"　strbuff ""　　　　　 int:10
strBuff = Replace(strBuff, "月", "/")　　　　　　　　　---->strDate "３１年４月"　strbuff "３１/４月"　int:10
strBuff = Trim(StrConv(strBuff, vbNarrow)) & "01"　　　---->strDate "３１年４月"　strbuff "３１/４/"　 int:10
intI = CInt(Mid(strBuff, 1, 2)) + 1988　　　　　　　　 ---->strDate "３１年４月"　strbuff "31/4/01"　　int:10
strBuff = CStr(intI) & Mid(strBuff, 3, 6)　　　　　　　---->strDate "３１年４月"　strbuff "31/4/01"　　int:2019
strBuff = DateAdd("m", -3 ,strBuff)　　　　　　　　　　---->strDate "３１年４月"　strbuff "2019/4/01"　int:2019
・ツリー全体表示
【80795】データを別アプリに再入力する方法
質問  たる  - 19/5/13(月) 0:54 -
引用なし
パスワード
   初めまして。
VBAにつきまして、恐縮ですがどうかご教授願います。

1.VBAで、別のアプリ内に入力されている文字を一旦コピー（保存）する。
2.コピーした内容を、別のPCから同じアプリに再入力する。

上記内容をVBAで行うことは可能でしょうか。

別のアプリというのが、社内で利用している顧客情報を入力するアプリです。
何故か貼り付けができず、直接入力しか受け付けないものなので、
コピーした内容をVBAで認識して、貼り付けではなくアプリ内に再入力はできないでしょうか。

例えば「090-1234-5678」と入力されている内容を、コピー→貼り付けではなく、
上記数字をVBAが1文字ずつ別アプリに入力できれば、と考えています。

何卒宜しくお願い致します。
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
83 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free