Excel VBA質問箱 IV

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

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


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

21 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【82073】色付きセル＆数値入りセルの個数を数えた...

へっぽこです - 22/10/13(木) 8:40 -


	引用なし

	パスワード

建設業です。
毎月の作業内容毎のユニット(1ユニット＝15分)を計算しています。
引き継がれている書式があり、その体裁は崩したくありません。

(A)入力セルについて
(A1)Sheets("月間ユニット集計")のRange("R18:DI41")に縦方向に31日、横方向に24時間(15分毎)に区切った月表があります。
(A2)月表は時間区分(定時間、時間外、深夜時間、休日、法定休日等々)にセル毎に色分けされています。
(A3)作業者は毎日当日の作業番号(6桁数値)をその作業の開始時間のセルに入力します。
(A4)1日の中で異なる作業が発生し、その都度作業番号を開始時間のセルに入力します。
(A5)作業が発生していない時間(昼休み、会議、出張等)は当該時間内のセルの色を無色にします。

(B)集計セルについて
(B1)Sheets("ユニット集計")のRange("A50:A69")に作業番号、Range("H50:N69")に時間区分が設定されています。
(B2)月の作業番号毎、時間区分毎のユニット数を月末に集計、入力します。

(C)留意すること
(C1)作業者の入力ミスで物件番号の入ったセルの着色を消している。→ユニット数にはカウントされない。
(C2)日の始まりの着色セルに物件番号を設定していない。→作業番号不明。
(C3)次の作業番号までの間のセルに無着色セルがある場合(A5)も次のセルが着色セル＆空白なら続いて同じ作業番号のユニットとしてカウントする。

(D)VBAでしたいこと
(D1)(B2)の集計、入力を自動、かつ短時間で処理したい。
(D2)(C1)、(C2)の入力設定忘れをメッセージ表示したい。

(E)試したこと
作業番号が入力されたセルの作業番号を、異なる作業番号が入力されているセルまでコピペし、
セルの色毎にそれを集計。集計後同じ作業番号が続くセルをClearContents。
→処理時間が永遠かと思われるほどかかりました。

どなたかお知恵を貸してくれる方、いらっしゃいましたら宜しくお願いします。

・ツリー全体表示


	【82072】Re:テーブルをやめる

りった - 22/9/28(水) 22:17 -


	引用なし

	パスワード

ありがとうございます!!
遅レスすみません m(_ _)m

・ツリー全体表示


	【82071】Re:ユーザー関数(引数・戻り値とも配列)...

ヘビー - 22/9/23(金) 19:05 -


	引用なし

	パスワード

変数名
C1,R1に似た物はPCによっては撥ねられます。
でもその内エラーにならなくなります。
ここが摩訶不思議。

Sub R()
a=0
End Sub

Sub C()
a=0
End Sub

Sub R1()
a=0
End Sub

Sub C1()
a=0
End Sub

なども、マクロマクロに表示され無い場合も。
でもその内表示されるようになります。
ここも摩訶不思議。
RとCは予約後らしい。

・ツリー全体表示


	【82070】Re:ユーザー関数(引数・戻り値とも配列)...

マナ - 22/9/10(土) 10:26 -


	引用なし

	パスワード

>p = Application.Transpose(Application.Transpose(p))

TypeName(p)="Range" のときだけでよかったかもしれません。

・ツリー全体表示


	【82069】Re:ユーザー関数(引数・戻り値とも配列)...

マナ - 22/9/10(土) 10:16 -


	引用なし

	パスワード

▼popopo さん：

>再現できました。C1#が不可は不思議

これも、よくわかりませんが、エラーにはなりませんでした。

Public Function Pu(p As Variant) As Long()　 '配列＆Range受取・配列戻り
　　p = Application.Transpose(Application.Transpose(p))
　　Dim ret() As Long: ReDim ret(1 To UBound(p))
　　ret(1) = p(1) + p(1) '和
　　ret(2) = p(1) - p(2)　'差
　　Pu = ret
End Function

・ツリー全体表示


	【82068】Re:ユーザー関数(引数・戻り値とも配列)...

popopo - 22/9/10(土) 2:25 -


	引用なし

	パスワード

マナさん、貴重なヒントありがとうございまうす。

再現できました。C1#が不可は不思議
足掛かりにして、もう少し反応を調べてみます。

=pu(pre(A1,B1)) '{57,0}スピル表示
=pu(C1#)　　　　'#VALUE!
=pu(pre(A1,B1)) '{57,0}スピル表示
=pu(pre(A1,B1)) '{57,0}スピル表示

ユーザー関数では、以下限定の模様ですね
　・引数はバリアント型
　・配列はindex=1から

・ツリー全体表示


	【82067】Re:ユーザー関数(引数・戻り値とも配列)...

マナ - 22/9/9(金) 22:26 -


	引用なし

	パスワード

▼popopo さん：

よくわかりませんが、これでエラーにはなりませんでした。

Public Function Pu(p() As Variant) As Long()　 '配列受取・配列戻り
　　Dim ret() As Long: ReDim ret(1 To UBound(p))
　　ret(1) = p(1) + p(2) '和
　　ret(2) = p(1) - p(2) '差
　　Pu = ret
End Function。

・ツリー全体表示


	【82066】ユーザー関数(引数・戻り値とも配列)にE...

popopo

- 22/9/9(金) 17:57 -


	引用なし

	パスワード

関数(引数・戻り値とも配列)を
Excelワークシートから配列を渡し、ユーザー関数として呼び出したい。
ご協力下さい。

・VBAコードからは、問題なく利用可能な関数Pu
・Excelワークシートから呼び出し不可。#VALUE!表示

・以下関数で挟み、VBAからは利用可能
　・Pre_関数(引数:文字列戻り値:配列)
　・Post関数(引数:配列　戻り値:文字列)

◎・xPack関数(引数:文字列　戻り値:文字列):パッケージシートからも利用可能
　種々関数を連結したく、高速化からも、直接呼出す方法はないでしょうか？
　宜しくお願い致します。

準備 A1=12, B1=45
結果
・C1=Pre(A1,B1)　　'{12,45}スピル表示
・C2=Pu(Pre(B1,C1) '#VALUE!
・C3=Pu(C1#)　　　 '#VALUE!
・C4=Pu({12,45})　 '#VALUE!
・C5=Pu(Pre("12","45")) '#VALUE!

・C11=Post(Pre(A1,B1))　　'#VALUE!
・C12=Post(Pu(Pre(B1,C1)))'#VALUE!
・C13=Post(Pu(C1#))　　　 '#VALUE!
・C14=Post(Pu({12,45}))　 '#VALUE!
・C15=Post(Pu(Pre("12","45"))) '#VALUE!

・C21=xPack(A1,B1) '-1881　正パッケージ関数

不具合を再現する単純コード演算内容は問わず
--
Public Function Pu(p() As Long) As Long() '配列受取・配列戻り
　　Dim ret()　As Long: ReDim ret(UBound(p))
　　ret(0) = p(0) + p(1) '和
　　ret(1) = p(0) - p(1) '差
　　Pu = ret
End Function

Public Function Pre(S1 As String, S2 As String) As Long()'演算　配列戻り
　　Dim ret() As Long: ReDim ret(1)
　　ret(0) = CInt(S1)
　　ret(1) = CInt(S2)
　　Pre = ret
End Function

Public Function Post(p() As Long) As String '加工、戻り値文字列
　　Post = p(0) * p(1) '積
End Function

Public Function xPack(S1 As String, S2 As String) As String '引数,戻り値文字列
　　xPack = Post(Pu(Pre(S1, S2)))
End Function
---

・ツリー全体表示


	【82065】Re:テーブルをやめる

マナ - 22/9/6(火) 14:35 -


	引用なし

	パスワード

▼りったさん：

>見た目を極力変えずにテーブルをやめるにはどうしたらよいでしょうか？

右クリック/テーブル/範囲に変換

・ツリー全体表示


	【82064】テーブルをやめる

りった - 22/9/6(火) 7:44 -


	引用なし

	パスワード

テーブル機能は嫌いです。
ほかの人が作成したファイルを流用した際、表がテーブルになっていることがあります。
見た目を極力変えずにテーブルをやめるにはどうしたらよいでしょうか？

・ツリー全体表示


	【82063】Re:PDF　連番保存

OK - 22/8/31(水) 11:58 -


	引用なし

	パスワード

なるべく元コードを生かすようにして書き換えました。

Sub test()
'名前をつけて保存
Dim Desktop_Path As String
Dim fileSaveName As String
Dim fileSaveName_Name As String
Dim fileSavePath As String
Dim kaku As String
Dim ws As Worksheet

　Set ws = ActiveSheet
　kaku = "pdf"
　Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
　fileSaveName = ws.Range("AI1").Value
　fileSaveName_Name = fileSaveName
　fileSavePath = Desktop_Path & "\" & fileSaveName_Name & "." & kaku
　'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
　'''ファイル名の末尾に(i)をつける
　If Dir(fileSavePath) <> "" Then
　　 k = 0
　　Do While Dir(fileSavePath) <> ""
　　　k = k + 1
　　　'保存ファイル名を取得
　　 fileSaveName_Name = fileSaveName & Format(k, "(0)")
　　 fileSavePath = Desktop_Path & "\" & fileSaveName_Name & "." & kaku
　　Loop
　End If
　ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileSavePath
　Set ws = Nothing
End Sub

・ツリー全体表示


	【82062】Re:PDF　連番保存

はる - 22/8/31(水) 9:38 -


	引用なし

	パスワード

詳細にありがとうございます。
流れを見て修正し、PDF保存まではできたものの、やはり（１）…と追加するところで手詰まりになってしまいます。

Dim k As Integer　が抜けていたことが原因かと思ったのですが見当違いでしょうか…。

Dim Desktop_Path As String
Dim k As Integer
'****デスクトップのパス取得
Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")

'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
'''ファイル名の末尾に(i)をつける
If Dir(Desktop_Path) <> "" Then
'保存ファイル名を取得
fileSaveName_name = Dir(Desktop_Path)
'保存先のフォルダを取得
Desktop_Path_path = Replace(fileSaveName, Desktop_Path_name, "")

'保存ファイル名の末尾に(i)をつける
k = 1
Do While Dir(Desktop_Path) <> ""
fileSaveName = Desktop_Path_path & Replace(Desktop_Path_name, ".pdf", "") & "(" & k & ")" & ".pdf"
k = k + 1
Loop
End If
'****アクティブシートをPDFファイルとして保存(デスクトップにA1セルに入力されている名前を付けて保存)
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
End With

・ツリー全体表示


	【82061】Re:PDF　連番保存

OK - 22/8/31(水) 8:58 -


	引用なし

	パスワード

はるさんの22/8/30(火) 17:34のコードにコメントを付加してみました。

Dim Desktop_Path As String
'****デスクトップのパス取得
Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
'****アクティブシートをPDFファイルとして保存(デスクトップにA1セルに入力されている名前を付けて保存)
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
End With

'****↓PDFファイルは作成済みなのでその後にファイル名を生成しても無意味。
’またfileSaveNameは変数宣言されてないし、fileSaveNameに何も格納されてないので
'Dir(fileSaveName) の戻り値は必ず""となるので、このIf文はスルーされる
'*****

'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
'''ファイル名の末尾に(i)をつける
If Dir(fileSaveName) <> "" Then
'保存ファイル名を取得
fileSaveName_name = Dir(fileSaveName)
'保存先のフォルダを取得
fileSaveName_path = Replace(fileSaveName, fileSaveName_name, "")

'保存ファイル名の末尾に(i)をつける
k = 1
Do While Dir(fileSaveName) <> ""
fileSaveName = fileSaveName_path & Replace(fileSaveName_name, ".pdf", "") & "(" & k & ")" & ".pdf"
k = k + 1
Loop
End If

・ツリー全体表示


	【82060】Re:PDF　連番保存

OK - 22/8/30(火) 18:10 -


	引用なし

	パスワード

考え方です。

PDFのファイルパスを生成する
↓
生成したファイルパスが存在したら存在しなくなるまでループ
する。
↓
PDFを生成したファイルパスで保存する。

・ツリー全体表示


	【82059】Re:PDF　連番保存

OK - 22/8/30(火) 18:03 -


	引用なし

	パスワード

PDF作成した後にファイル名を生成しても意味がない
ですよ。
コードをよく見ましょう。

・ツリー全体表示


	【82058】Re:PDF　連番保存

はる - 22/8/30(火) 17:34 -


	引用なし

	パスワード

ありがとうございます。参考に作成してみましたが、上書き保存されてしまいます。
初心者で分からないことだらけで申し訳ございません…。

名前をつけて保存
Dim Desktop_Path As String
Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
End With
'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
'''ファイル名の末尾に(i)をつける
If Dir(fileSaveName) <> "" Then
'保存ファイル名を取得
fileSaveName_name = Dir(fileSaveName)
'保存先のフォルダを取得
fileSaveName_path = Replace(fileSaveName, fileSaveName_name, "")

'保存ファイル名の末尾に(i)をつける
k = 1
Do While Dir(fileSaveName) <> ""
fileSaveName = fileSaveName_path & Replace(fileSaveName_name, ".pdf", "") & "(" & k & ")" & ".pdf"
k = k + 1
Loop
End If

・ツリー全体表示


	【82057】Re:解決しました。

OK - 22/8/30(火) 16:22 -


	引用なし

	パスワード

今更ですが。
エラー処理で挟む、という方法もあります。

Err.Clear
On Error Resume Next
ActiveSheet.Shapes("Picture 2467").Delete
On Error GoTo 0

・ツリー全体表示


	【82056】Re:PDF　連番保存

OK - 22/8/30(火) 8:53 -


	引用なし

	パスワード

参考HPです。

ht　tps://qiita.com/yagi_eng/items/cc7570b3878818a8e495

・ツリー全体表示


	【82055】Re:PDF　連番保存

OK - 22/8/30(火) 8:48 -


	引用なし

	パスワード

Dir関数の戻り値でファイルの有無の判定ができます。
ファイルパスが既に存在する場合はDo ~ Loopを使って
カウントアップして(1),(2)をファイル名に付加してファイル
パスが存在しなくなるまでループしてファイル名を生成
するようにしてはいかがでしょう？

・ツリー全体表示


	【82054】PDF　連番保存

はる - 22/8/29(月) 17:29 -


	引用なし

	パスワード

PDF保存をする際に、同じフォルダ名があると上書き保存されてしまいます。
同じファイルがある場合、～(1).pdfと、連番で保存していきたいです。

デスクトップに保存までのVBAは書けましたが、連番がどうにもうまくいきません。

ご助言いただけますでしょうか。

'名前をつけて保存
　　Dim Desktop_Path As String
　　Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
　　With ActiveSheet
　　　　.ExportAsFixedFormat _
　　　　Type:=xlTypePDF, _
　　　　Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
　　End With

　　Application.DisplayAlerts = True

・ツリー全体表示


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

21 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free