Excel VBA質問箱 IV

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

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


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

73 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81015】Re:サーバー内にあるフォルダとファイル...

γ - 19/7/9(火) 7:04 -


	引用なし

	パスワード

>一応完成したのは良いのですが、ご自分で作成したように書いていますが、 ht tp://pg-sample.sagami-ss.net/?eid=1 こちらのコードをコピペしただけですよね。更新日時とサイズについては、フルパスに対して、FileDateTime,FileLenというVBAに組込の関数を使えば可能です。難しくも無いので、コードは示す必要もないでしょう。ところで、私が紹介した井上さんのサイト記事は読んだのでしょうか？更新年月日とサイズも表示するサンプルになっています。それを参考にする積もりはないのですか？もっとも、井上さんのコードをそのまま使ってなにか支障ありますか？もともとフリーソフト大賞に選ばれた ht tp://www.asahi-net.or.jp/~ef2o-inue/download/sub09_010.html の簡易版でもあるので、そのまま使用しても全く問題ないはずです。 # 紹介したコードにある機能を参考にすることなく、 # 出典を隠した別の他人作成のコードに、機能追加してくれとか、 # 質問にあたっての取り組み方がちょっと安直過ぎませんか？ # 少なくとも出典を明示すべきでしょう。 # それが作者に対する礼儀でもあるでしょう。

・ツリー全体表示


	【81014】Re:オートフィル後の可視セル抽出に関して

マナ - 19/7/8(月) 23:53 -


	引用なし

	パスワード

▼まみさん：

>ループ１回目→メッセージボックス「まさよ」
>ループ２回目→メッセージボックス「かおる」
>ループ３回目→メッセージボックス「あかり」

Sub test()
　　Dim rr As Range
　　Dim r As Range
　　Dim c As Range
　　
　　Set rr = ActiveSheet.AutoFilter.Range
　　
　　On Error Resume Next
　　Set r = Intersect(rr, rr.Offset(1)).Columns(3).SpecialCells(xlCellTypeVisible)
　　On Error GoTo 0
　　
　　If Not r Is Nothing Then
　　　　For Each c In r
　　　　　　MsgBox c.Value
　　　　Next
　　End If
　　
End Sub

・ツリー全体表示


	【81013】Re:VBAによる電圧自動測定

ムズロウ

- 19/7/8(月) 22:21 -


	引用なし

	パスワード

返信ありがとうございます

UBoundで上限を指定しているのですね
明日試してみます

・ツリー全体表示


	【81012】Re:サーバー内にあるフォルダとファイル...

Romi - 19/7/8(月) 21:09 -


	引用なし

	パスワード

γさん

一応完成したのは良いのですが、
これにファイル名の後ろに更新日とサイズを表記するにはどうしたら良いでしょうか・・？基本的なことで申し訳ありません。
ご教授願います。

'//ワークブックオープンでフォルダ選択ダイアログを表示
Private Sub Workbook_Open()
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If .Show = True Then
　　　　　　ファイル一覧 .SelectedItems(1)
　　　　End If
　　End With
End Sub

'//選択されたフォルダのファイル一覧を取得するプロシージャをコール
Sub ファイル一覧(ByVal folpath As String)　　
　　'全て(数式、文字列、書式、コメント、アウトライン)クリア
　　Cells.Select
　　Selection.Clear
　　'列の幅、フォントサイズをセット
　　Selection.ColumnWidth = 4
　　Selection.Font.Size = 9
　　Range("A1").Select
　　'ファイル一覧をサブフォルダまで取得して表示する
　　Application.ScreenUpdating = False
　　Call ファイル一覧を取得(folpath, 1, 0)
　　Application.ScreenUpdating = True
　　'終了メッセージ
　　MsgBox "おわりました", vbInformation
End Sub

'//ファイル一覧を再帰的に取得してシートに表示する
'//引数　gyo：出力開始行番号
'//　　　clm：出力開始列番号(1列目からの相対値)
Sub ファイル一覧を取得(ByVal folpath As String, ByRef gyo As Long, ByVal clm As Integer)
　　Dim buf As String
　　Dim fol As Object
　　'ルートフォルダを表示
　　Cells(gyo, 1) = "【" & CStr(gyo) & "】"
　　Cells(gyo, 2 + clm) = folpath
　　gyo = gyo + 1
　　'ファイル一覧を取得
　　buf = Dir(folpath & "\*.*", vbNormal)
　　Do While buf <> ""
　　　　Cells(gyo, 1) = "【" & CStr(gyo) & "】"
　　　　Cells(gyo, 2 + clm) = "∟"
　　　　Cells(gyo, 2 + clm + 1) = buf
　　　　gyo = gyo + 1
　　　　buf = Dir()
　　Loop
　　'サブフォルダからファイル一覧を取得
　　With CreateObject("Scripting.FileSystemObject")
　　　　For Each fol In .getFolder(folpath).SubFolders
　　　　　　Call ファイル一覧を取得(fol.Path, gyo, clm + 1)
　　　　Next fol
　　End With
End Sub

・ツリー全体表示


	【81011】Re:VBAによる電圧自動測定

よろずや - 19/7/8(月) 19:58 -


	引用なし

	パスワード

For j = 0 To UBound(DATA) 　　new_Worksheets.Cells(j + 4, i - 19) = DATA(j) 　　TOTAL = TOTAL + DATA(j) 　　COUNT = COUNT + 1 Next j 　　：＜途中省略＞　　： AVERAGE = TOTAL / COUNT ってことかな？

・ツリー全体表示


	【81010】Re:VBAによる電圧自動測定

ムズロウ - 19/7/8(月) 19:32 -


	引用なし

	パスワード

▼ムズロウさん：
>返信ありがとうございます
>確認してみます

エラーになる時のjの値ですが様々な値をとり、特にエラーにどう影響してるのか分かりません、2,17の時にエラーが出たことは確認しました
それよりもDATA(j)がインデックスが有効範囲にないという表示があり気になりました

・ツリー全体表示


	【81009】Re:オートフィル後の可視セル抽出に関して

Jaka - 19/7/8(月) 17:42 -


	引用なし

	パスワード

オートフィル？？

>列数の場合はうまくいきませんでした。

よく解ってないけど。

fot Each セル１ in 可視セル範囲.columns(3).Areas
　　for Each セル２ in セル１

・ツリー全体表示


	【81008】Re:精算日を自動算出する関数式

Jaka - 19/7/8(月) 17:10 -


	引用なし

	パスワード

=IF(WEEKDAY(A1)<5,6-WEEKDAY(A1)+A1,7-WEEKDAY(A1)+6+A1)

・ツリー全体表示


	【81007】オートフィル後の可視セル抽出に関して

まみ - 19/7/8(月) 16:15 -


	引用なし

	パスワード

はじめまして。
ExcelVBAではオートフィル操作に弱いというのは知っていますが、
業務上どうしてもやらなければなりません。

そこで質問があります。

以下、オートフィルして絞りこんだ行の中の１つの値を
上から順番に取得するというロジックを書きたいのですが、
うまくいきません。

つまり、

　　　A　　　　B　　　　C　　　　D　　
１　りんご　　AAA 　　まさよ　　海
２　みかん　　BBBB　　かおる　　海
３　バナナ　　DIDI　　りえ　　　山
４　キウイ　　FRFR　　なおこ　　山
５　いちご　　NNN　　　あかり　海

↓

オートフィルでD列から「海」だけ取り出す
　　　A　　　　B　　　　C　　　　D　　
１　りんご　　AAA 　　まさよ　　海
２　みかん　　BBBB　　かおる　　海
５　いちご　　NNN　　　あかり　海

↓

C列の女性の名前を上から1件ずつメッセージ表示

ループ１回目→メッセージボックス「まさよ」
ループ２回目→メッセージボックス「かおる」
ループ３回目→メッセージボックス「あかり」

これに関して、色々なロジックをネットで調べましたが
うまくできません。

なお、「意外と使えるExcelでオートフィルタで表示しているセルだけ取得するVBA」というページも拝見しましたが、これだと行数はちゃんと取得できるものの、
列数の場合はうまくいきませんでした。

どう書けばよいのでしょうか。

ご教示よろしくお願いいたします。

・ツリー全体表示


	【81006】PCの移行に伴うVBAの不具合について

beans

- 19/7/8(月) 14:12 -


	引用なし

	パスワード

OS Windows7 excel2013のPCからWindows10 excel2019のPC へ移行したところ、
これまで問題なく動いていた下記のマクロが、
（Rectangleクラスのcopyメソッドが失敗しました）として、完了できなくなってしまいました。
狙った行の抽出をするところまでは、動いているようなのですが、抽出された行にオートシェイプで作成した図形を張り付ける、赤色の下線を引くといった動作ができておりません。
エラーの際にデバッグを選択すると、下記Sub連続用4()　内のselection copyというところが黄色くマークアップされていました。

どのようにすればエラーを回避し、動作を完了できますでしょうか？
お助けいただけましたら幸いです。

Sub 連続用5()
　　Sheets("連続用").Select
　　Range("Y5:AC3000").Select
　　Selection.ClearContents
　　Range("A1").Select
End Sub
Sub 連続用2()
　　Sheets("連続用").Select
　　Application.ScreenUpdating = False
　　
　　Dim meibo As Worksheet
　　
　　Set meibo = Worksheets("連続用")
　　　　
　　ro = 5
　　While meibo.Cells(ro, 1) <> ""

　　Range("Y4:AC4").Select
　　Selection.Copy
　　Cells(ro, 25).Select
　　ActiveSheet.Paste
　　　　ro = ro + 1
　　Wend
　　Application.ScreenUpdating = True

End Sub

Sub 連続用3()
　　Sheets("連続用").Select
　　Application.ScreenUpdating = False

　　Rows("5:3000").Select
　　Application.CutCopyMode = False
　　Selection.Sort Key1:=Range("AC5"), Order1:=xlAscending, Key2:=Range("D5") _
　　　　, Order2:=xlAscending, Key3:=Range("E5"), Order3:=xlAscending, Header:= _
　　　　xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:= _
　　　　xlSortNormal, DataOption3:=xlSortNormal
　　Range("A1").Select

End Sub

Sub 連続用4()

　　Sheets("連続用").Select
　　Application.ScreenUpdating = False
　　
　　Dim meibo As Worksheet
　　
　　Set meibo = Worksheets("連続用")
　　　　
　　ro = 5
　　p = 6
　　While meibo.Cells(ro, 1) <> ""

　　　　If (Cells(ro, 29) = Cells(p, 29)) = True Then
　　　　　　If (Cells(ro, 4) = Cells(p, 4)) = True Then
　　　　　　　　If ((Cells(ro, 6) + Cells(2, 29)) > Cells(p, 5)) = True Then
　　　　　　　　　　Range(Cells(ro, 5), Cells(p, 6)).Interior.ColorIndex = 35
　　　　　　　　　　
　　　　　　　　　　If (Cells(ro, 21) = Cells(p, 21)) = True Then
　　　　　　　　　　　　If (Cells(ro, 5) <> Cells(p, 5)) = True Then
　　　　　　　　　　　　　　If (Cells(ro, 6) <> Cells(p, 6)) = True Then
　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　　ActiveSheet.Shapes("AutoShape 18").Select
　　　　　　　　　　　　　　　　Selection.Copy
　　　　　　　　　　　　　　　　Cells(ro, 1).Select
　　　　　　　　　　　　　　　　ActiveSheet.Paste
　　　　　　　　　　　　　　　　Selection.ShapeRange.IncrementTop 5.25
　　　　　　　　　　　　　　　　Selection.ShapeRange.IncrementLeft 2.25
　　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　　　
　　　　　　　　　　If ((Cells(ro, 35) + Cells(p, 35)) - (Cells(ro, 34) + Cells(p, 34))) <= ((Cells(ro, 16) + Cells(p, 16)) - Cells(2, 30)) = True Then
　　　　　　　　　　　　ActiveSheet.Shapes("AutoShape 18").Select
　　　　　　　　　　　　Selection.Copy
　　　　　　　　　　　　Cells(ro, 16).Select
　　　　　　　　　　　　ActiveSheet.Paste
　　　　　　　　　　　　Selection.ShapeRange.IncrementTop 5.25
　　　　　　　　　　　　Selection.ShapeRange.IncrementLeft 2.25
　　　　　　　　　　End If
　　　　　　　　　　
　　Cells(ro, 33).Select
　　ActiveCell.FormulaR1C1 = "1"
　　Cells(p, 33).Select
　　ActiveCell.FormulaR1C1 = "1"
　　
　　Range(Cells(ro, 1), Cells(p, 23)).Select
　　Selection.Borders(xlDiagonalDown).LineStyle = xlNone
　　Selection.Borders(xlDiagonalUp).LineStyle = xlNone
　　With Selection.Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　End With
　　With Selection.Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = 3
　　End With
　　With Selection.Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = 3
　　End With
　　With Selection.Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　　　.ColorIndex = xlAutomatic
　　End With
　　
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　
　　　　ro = ro + 1
　　　　p = ro + 1
　　Wend
　　Application.ScreenUpdating = True

End Sub

・ツリー全体表示


	【81005】精算日を自動算出する関数式

担当C - 19/7/8(月) 11:35 -


	引用なし

	パスワード

エクセルの関数を教えてください。

例えば、7/4-7/10に精算した経費は7/12に支払います。
7/11-7/17に精算した経費は7/19に支払います。

このように、ある週の木曜から水曜を基準として
水曜日の２日後である金曜の日付（精算日）を
自動で算出できる関数を教えていただきたいです。

自分で調べてみたのですが、わかりませんでした。。

宜しくお願い致します。

・ツリー全体表示


	【81004】Re:サーバー内にあるフォルダとファイル...

Romi - 19/7/7(日) 16:37 -


	引用なし

	パスワード

γさん

ありがとうございます。
ちょっと試してみます。

進捗は後ほど書きます。

・ツリー全体表示


	【81003】Re:サーバー内にあるフォルダとファイル...

γ - 19/7/6(土) 21:49 -


	引用なし

	パスワード

こちらの記事を参考にして研究して下さい。 ht tp://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html 　↑わざとスペースを入れています。とってジャンプしてください。

・ツリー全体表示


	【81002】サーバー内にあるフォルダとファイル名を...

Romi - 19/7/6(土) 21:02 -


	引用なし

	パスワード

サーバー上にある、フォルダ内のファイル名を一括で出したいです。

Sub Call_GetFileList()

　　GetFileList03 "C:\Program Files"
　　
End Sub

Sub GetFileList03(Search_Path)
Dim objFs As Object, objFiles As Object, objFolders As Object
Dim File_Path As String, File_Name As String
Dim i As Long, arrData
'処理が遅くなるのでプログラム実行中の画面描画を停止する
Application.ScreenUpdating = False
Set objFs = CreateObject("Scripting.FileSystemObject")
　　'パスの取得
　　For Each objFolders In objFs.GetFolder(Search_Path).SubFolders
　　　　'サブフォルダまで検索するために再帰実行
　　　　GetFileList03 objFolders.Path
　　Next
　　
　　'ファイル名の取得
　　For Each objFiles In objFs.GetFolder(Search_Path).Files
　　　　'\マークを区切り文字として各文字列を配列に代入
　　　　arrData = Split(objFiles.Path, "\")
　　　　
　　　　'セルに配列の各値を書き込む
　　　　For i = 0 To UBound(arrData)
　　　　　　ActiveCell.Offset(0, i).Value = arrData(i)
　　　　Next i
　　　　
　　　　ActiveCell.Offset(1, 0).Select　　　
　　Next
　　
End Sub

↑
ところが、これだとただ文字を羅列するだけで、少々見づらいです。
なので、フォルダごとに上手く結合とか罫線をつけて見やすいレイアウトに出来ないものでしょうか？すいません、上手く表現が出来なくて。。

・ツリー全体表示


	【81001】Re:VBAによる電圧自動測定

ムズロウ - 19/7/6(土) 12:57 -


	引用なし

	パスワード

返信ありがとうございます
確認してみます

・ツリー全体表示


	【81000】Re:VBAによる電圧自動測定

よろずや - 19/7/5(金) 21:18 -


	引用なし

	パスワード

500回と指定したら必ず500個のデータが返ることは、保証されているのでしょうか？

Worksheets(new_Worksheets.Name).Cells(j + 4, i - 19) = DATA(j)

エラーで止まった時の j の値を確認しましょう。

・ツリー全体表示


	【80999】Re:ｴｸｾﾙ2016ですがｸﾗｯｼｭします

goushi - 19/7/5(金) 18:56 -


	引用なし

	パスワード

早速のご回答ありがとうございます
再度調整してみます

・ツリー全体表示


	【80998】Re:ｴｸｾﾙ2016ですがｸﾗｯｼｭします

γ - 19/7/5(金) 18:15 -


	引用なし

	パスワード

小計の処理のなかでセル内容を変更すると
それがchangeイベントを発生させ・・
と繰り返しが起きるからじゃないですか？
回避するには
Application.EnableEvents=False
セル変更
Application.EnableEvents=True
とするとよいでしょう。
ネットで検索してみてください。

・ツリー全体表示


	【80997】Re:ｴｸｾﾙ2016ですがｸﾗｯｼｭします

goushi - 19/7/5(金) 17:19 -


	引用なし

	パスワード

新しいブックで確認したところ以下のコードが原因のようでした
イベントプロシージャの部分の
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Call 小計
End Sub

それを以下のように変更すると
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Call 小計
End Sub

クラッシュしなくなりました
エクセル２０１３だと問題なく動くようなのですが
よろしければお教えいただけないでしょうか

・ツリー全体表示


	【80996】VBAによる電圧自動測定

ムズロウ

- 19/7/5(金) 0:18 -


	引用なし

	パスワード

Agilent Technologies社の6 1/2 Degit Multimeter2台による電圧自動測定で、エラー9が出てしまい困っています。
コードの概略としましては１測定温度に対し、2出力の電圧を500回測定し、その平均を出しSheet1に記述していくというものです。

以下コード

Private Sub let_mesurement_Click()
　　Dim i As Integer
　　Dim j As Integer
　　Dim DATA As Variant
　　Dim TOTAL As Single
　　Dim AVERAGE As Single
　　Dim temp As Integer
　　Dim count As Integer
　　
　　count = Sheet1.Cells(5, 11)
　　
　　temp = InputBox("測定温度は何℃ですか？", "温度確認")
　　
　　Dim new_Worksheets As Variant
　　Set new_Worksheets = Worksheets.Add()
　　new_Worksheets.Name = Str(temp) & "℃"
　　
　　Worksheets(new_Worksheets.Name).Cells(1, 1) = temp & "℃"
　　Worksheets(new_Worksheets.Name).Cells(2, 3) = "平均出力電圧[V]"
　　Worksheets(new_Worksheets.Name).Cells(1, 4) = "電圧1"
　　Worksheets(new_Worksheets.Name).Cells(1, 5) = "電圧2"

　　Dim RM As New VisaComLib.ResourceManager
　　Dim DMM As New VisaComLib.FormattedIO488
　　　　
　　For i = 23 To 24
　　
　　　　Set DMM.IO = RM.Open("GPIB0::" & i & "::INSTR") '入力されたVISAアド　　　　　　　　　　　　　　　　　　　　　　　　レスにてセッションオープン
　　
　　　　DMM.IO.Timeout = 120000　　　'タイムアウト時間120秒に設定
　　　　TOTAL = 0
　　　　AVERAGE = 0
　　
　　　　With DMM
　　　　　　.WriteString "*RST;*CLS"　'リセット、クリア
　　　　　　.WriteString "CONF:VOLT:DC AUTO" ', 1E-5"　 'DCV測定
　　　　　　.WriteString "SENS:VOLT:DC:NPLC 0.5"　 '積分時間を0.5PPLに設定
　　　　　　.WriteString "TRIG:COUN 500"　　'トリガカウント500回　34401Aの　　　　　　　　　　　　　　　　　　　　　　　内部メモリの限界512回
　　　　　　.WriteString "INIT"　　 '測定開始
　　　　　　.WriteString "*OPC?"　　'動作完了確認（ここでは測定の完了を確　　　　　　　　　　　　　　　　　　　　　　　認）
　　　　　　.ReadString　　　　　　　 '測定が完了すると1 が返る
　　　　　　.WriteString "FETC?"
　　　　　　
　　　　　　DATA = .ReadList(ASCIIType_R4, ",")
　　
　　　　　　For j = 0 To 499
　　　　　　 Worksheets(new_Worksheets.Name).Cells(j + 4, i - 19) = DATA(j)
　　　　　　　　TOTAL = TOTAL + DATA(j)
　　　　　　Next j
　　
　　　　　　.IO.Close
　　
　　End With
　　
　　Set DMM = Nothing
　　Set RM = Nothing
　　
　　AVERAGE = TOTAL / 500
　　　　
　 Worksheets(new_Worksheets.Name).Cells(2, i - 19) = AVERAGE
　　
　 Next i
　　
　 Sheet1.Cells(count + 2, 1) = temp
　　
　 Sheet1.Cells(count + 2, 2) = Worksheets(new_Worksheets.Name).Cells(2, 4)
　 Sheet1.Cells(count + 2, 3) = Worksheets(new_Worksheets.Name).Cells(2, 5)
　　
　　Sheet1.Cells(5, 11) = count + 1
　　
　　Set new_Worksheets = Nothing
　　
　　MsgBox "測定完了!"
　　
End Sub

コード以上

変数iはGPIBのアドレスです
Worksheets(new_Worksheets.Name).Cells(j + 4, i - 19) = DATA(j)
の部分でエラーが出るようですが、うまく機能するときもあり原因が分かりません
当方VBAの知識はあまりなくコード自体も元あったものを少し書き換えた形になります。自分の勉強不足ではありますが、こちらに質問したほうが早いかと思い投稿させていただいた次第です。
自分でも調べてみますがどうぞよろしくお願いします。

・ツリー全体表示


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

73 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free