Excel VBA質問箱 IV

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

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


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

44 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【81604】Re:重複Key毎の合計を求める

γ - 21/1/21(木) 23:24 -


	引用なし

	パスワード

遅くなりました。

dictionaryとは、
Key →　Item
という対応関係を管理する容れ物です。

・Keyは文字列とか数値などをとることが多いですが、
・Itemも色々なものを保持することができます。
既に提示されたのは、配列の行番号をとったものですが、
（提示された方法のように）配列そのものを持たせることもできます。

こんな感じになるでしょう。参考にしてみて下さい。

Sub test()
　　Dim dic As Object
　　Dim k As Long, j As Long, r As Long
　　Dim s As String
　　Dim v As Variant
　　Dim itm As Variant
　　Dim key As Variant

　　Set dic = CreateObject("Scripting.Dictionary")

　　For k = 2 To 10
　　　　s = Cells(k, 1).Value
　　　　If Not dic.Exists(s) Then
　　　　　　v = Cells(k, 2).Resize(1, 6).Value
　　　　　　dic(s) = v
　　　　Else
　　　　　　'いったん取り出し
　　　　　　itm = dic(s)

　　　　　　'各要素に加算
　　　　　　v = Cells(k, 2).Resize(1, 6).Value
　　　　　　For j = 1 To 6
　　　　　　　　itm(1, j) = itm(1, j) + v(1, j)
　　　　　　Next

　　　　　　'再度格納
　　　　　　dic(s) = itm
　　　　End If
　　Next
　　Sheet2.Range("A2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)

　　'結果をシートに書き出す
　　r = 1
　　For Each key In dic
　　　　itm = dic(key)
　　　　r = r + 1
　　　　Sheet2.Cells(r, 2).Resize(1, 6) = itm
　　Next
End Sub

考え方に焦点を当てていますので、元データの行数や列数とか、
転記先の一行目の項目名、などは適当にしています。
そちらで修正して下さい。
また、各配列は、あえて一次元に変換せず、二次元のままにしています。

・ツリー全体表示


	【81603】Re:重複Key毎の合計を求める

マナ - 21/1/21(木) 18:42 -


	引用なし

	パスワード

▼assya さん：

γさんの、ここを含む掲示板での回答を見て
わたしも使えるようになった方法です。

空の２次元配列を用意して、
各要素に加算を繰り返すことで集計します。
dictionaryには、配列のindexを登録していす。

Sub test()
　　Dim dic As Object
　　Dim w()
　　Dim r As Long, c As Long
　　Dim v
　　Dim s As String
　　Dim n As Long
　　
　　Set dic = CreateObject("scripting.dictionary")
　　
　　v = Range("A1:G9").Value
　　
　　ReDim w(1 To UBound(v, 1), 1 To UBound(v, 2))
　　
　　For r = 1 To UBound(v, 1)
　　　　s = v(r, 1)
　　　　If Not dic.exists(s) Then
　　　　　　dic(s) = dic.Count + 1
　　　　　　w(dic(s), 1) = s
　　　　End If
　　　　n = dic(s)
　　　　For c = 2 To UBound(v, 2)
　　　　　　w(n, c) = w(n, c) + v(r, c)　'★ここで加算
　　　　Next
　　Next
　　
　　Range("A21").Resize(dic.Count, UBound(w, 2)).Value = w
　　
End Sub

・ツリー全体表示


	【81602】Re:重複Key毎の合計を求める

assya - 21/1/21(木) 15:09 -


	引用なし

	パスワード

▼γ さん：
>(2)既存のキーがある場合、
>・dictionaryのitemを変数に取得する
>・その行の配列の各要素を、その配列変数に要素ごとに加算する。

アドバイスいただきありがとうございます。

"・その行の配列の各要素を、その配列変数に要素ごとに加算する。" ここの部分なのですが、既存のdictionaly　Keyに対して、加算してitemをaddしなおすには、どういった書き方をするのでしょうか...？
既存のKeyをselectしてそこのitemに入れる、という書き方がわからずでして。
度々申し訳ありませんがわかりましたらご助言いただけないでしょうか。

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

・ツリー全体表示


	【81601】Re:重複Key毎の合計を求める

γ - 21/1/21(木) 7:39 -


	引用なし

	パスワード

この場合のdictionaryのitemは配列とします。
(1)新たなキーの場合、
・その行の各要素を持つ配列をitemにセットする
(2)既存のキーがある場合、
・dictionaryのitemを変数に取得する
・その行の配列の各要素を、その配列変数に要素ごとに加算する。
・改めて、それをdictionaryのitemにセットする。
ということになります。

・ツリー全体表示


	【81600】重複Key毎の合計を求める

assya - 21/1/20(水) 21:49 -


	引用なし

	パスワード

VBA初心者です。表題の件につきまして調べ・試し数日悩みまして、いよいよ解決方法がなくここで質問させてください。

以下のようなデータがあります。
Column1をキーにして、重複を除外、Column2以降（7以降も30~40程データがあります）を合計したいです。

そして我儘ですが勉強のためにdictionaly型で実装したいです。

FOR分をまわして、If Not myDic.exists(myList(i, 1)) Then でキーの重複を除外することまではできたのですが、
下記例でいうところのキー(AAAAA) × Column2 の合計値を13に計算するという部分が理解できていません。

==================
Column1　　　　Column2　　　　Column3　　　　Column4　　　　Column5　　　　Column6　　　　Column7
AAAAA　　　　10.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　10.00
BBBBB　　　　0.00　　　　2.00　　　　3.00　　　　3.00　　　　0.00　　　　0.00
CCCCC　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00
BBBBB　　　　0.00　　　　5.00　　　　6.00　　　　4.00　　　　0.00　　　　0.00
AAAAA　　　　1.00　　　　4.00　　　　1.50　　　　4.00　　　　0.00　　　　0.00
AAAAA　　　　2.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00
BBBBB　　　　3.00　　　　1.00　　　　0.50　　　　0.00　　　　0.00　　　　0.00
BBBBB　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00
CCCCC　　　　8.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00
==================
↓
==================
Column1　　　　Column2　　　　Column3　　　　Column4　　　　Column5　　　　Column6　　　　Column7
AAAAA　　　　13.00　　　　4.00　　　　1.50　　　　4.00　　　　0.00　　　　10.00
BBBBB　　　　3.00　　　　8.00　　　　9.50　　　　7.00　　　　0.00　　　　0.00
CCCCC　　　　8.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00　　　　0.00
==================

全然間違っていると思うのですが、以下に現状のソースを載せます。

Sub sample()

Dim myDic As Object
Dim myKey As Variant
Dim myItem As Variant
Dim Value As Variant
Dim myList As Variant
Dim i, u As Long

　　Set myDic = CreateObject("Scripting.Dictionary")

　　'A列,AF列のデータ全体DTを変数に格納
　　myList = Range("A8:AF18").Value
　　
　　For i = 1 To UBound(myList, 1) 'DTのRow分くりかえす

　　　　myKey = myList(i, 1)
　　　　
　　　　'Keyが空かチェック
　　　　If Not myList(i, 1) = Empty Then
　　　　　　
　　　　　　If Not myDic.exists(myList(i, 1)) Then　'重複チェック

　　　　　　　　'重複がない場合Itemを登録
　　　　　　　　For u = 2 To 32
　　　　　　　　　　myItem = myList(i, u)
　　　　　　　　　　Debug.Print "myItemは" & myItem & "です"
　　　　　　　　Next u
　　　　　　　　
　　　　　　　　'keyを辞書登録
　　　　　　　　myDic.Add myList(i, 1), myItem
　　　　　　　　
　　　　　　Else
　　　　　　　　'加算
　　　　　　　　For u = 2 To 32
　　　　　　　　　　myItem = myList(i, u) + myList(i, u)
　　　　　　　　　　Debug.Print "合算後myItemは" & myItem & "です"
　　　　　　　　Next u
　　　　　　End If
　　　　End If
　　Next

　　'重複していないリストを格納
　　myKey = myDic.Keys
　　
　　'重複を除いたkeyの一覧を出力
　　For i = 0 To myDic.Count - 1
　　　　Debug.Print myKey(i)
　　Next

　　'合計を格納
　　'myItem = myDic.items
　　
　　For i = 0 To myDic.Count - 1
　　　　Debug.Print "キーの値：" & myKey(i)
　　Next

　　'リストを出力
　　For i = 0 To UBound(myKey)
　　　　Cells(i + 25, 1).Value = myKey(i)
　　　　For u = 2 To 33
　　　　　　Cells(i + 25, u).Value = myItem(i, u)
　　　　Next u
　　Next

　　'開放
　　Set myDic = Nothing

End Sub

・ツリー全体表示


	【81599】Re:可視セルの値をクリップボードに格納...

sinzo - 21/1/19(火) 21:28 -


	引用なし

	パスワード

クリップボードからText取得し、再度登録する。

Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy

Dim str As String
　With New DataObject
　　 .GetFromClipboard
　　　str = .GetText
　End With
　Application.CutCopyMode = False
　With New DataObject
　　.SetText str
　　.PutInClipboard
　End With

・ツリー全体表示


	【81598】Re:PDFへのデータ差し込み

junhoshi - 21/1/19(火) 9:43 -


	引用なし

	パスワード

ありがとうございます。詳細まで理解したわけではありませんが実行できました。ラジオボタンの操作はまだ、試していませんので後々ご報告いたします。

・ツリー全体表示


	【81597】Re:可視セルの値をクリップボードに格納...

コウジ - 21/1/18(月) 9:59 -


	引用なし

	パスワード

▼sinzo さん：
>>With clipboard
>>　　.SetText Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
>>　　.PutInClipboard　　　　　　
>>　　.GetFromClipboard　　　　　
>>End With
>
>簡単なのはこれで
>Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
>
>区切り文字で結合するなら、こんなかんじかな
>Dim aRng As Range, tRng As Range
>Dim Txt As String
>Txt = ""
>For Each aRng In Range(Range("D10"), Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Areas
>　For Each tRng In aRng
>　Txt = Txt & "," & tRng.Text
>　Next
>Next
>Txt = Replace(Txt, ",", "", 1, 1)
>
>　Dim clipboard　 As New DataObject
>　With New DataObject
>　　.SetText Txt
>　　.PutInClipboard
>　　'.GetFromClipboard
>　End With

確かに下記の方法だと簡単ですが、処理が終わると（オートフィルタを外す）と
クリップボードに格納してあった値はなくなってしまいます。
クリップボードに保持したままエクセルを閉じたいのですが・・・

>簡単なのはこれで
>Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
>

・ツリー全体表示


	【81596】Re:可視セルの値をクリップボードに格納...

sinzo - 21/1/16(土) 18:36 -


	引用なし

	パスワード

>With clipboard
>　　.SetText Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
>　　.PutInClipboard　　　　　　
>　　.GetFromClipboard　　　　　
>End With

簡単なのはこれで
Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy

区切り文字で結合するなら、こんなかんじかな
Dim aRng As Range, tRng As Range
Dim Txt As String
Txt = ""
For Each aRng In Range(Range("D10"), Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Areas
　For Each tRng In aRng
　Txt = Txt & "," & tRng.Text
　Next
Next
Txt = Replace(Txt, ",", "", 1, 1)

　Dim clipboard　 As New DataObject
　With New DataObject
　　.SetText Txt
　　.PutInClipboard
　　'.GetFromClipboard
　End With

・ツリー全体表示


	【81595】Re:PDFへのデータ差し込み

sinzo - 21/1/16(土) 17:34 -


	引用なし

	パスワード

ラジオボタンは,
ボタン名　男、女
グループ名　Radio Button1
でてすとしました。

[81584]
.getField("text").Value = CStr(ActiveSheet.Cells(i, 1).Value)
.getField("Radio Button1").Value = ActiveSheet.Cells(i, 2).Value

・ツリー全体表示


	【81594】Re:PDFへのデータ差し込み

sinzo - 21/1/16(土) 17:12 -


	引用なし

	パスワード

Win10,ProDC2015でも２通目から先頭の０抜けるの確認しました。
対策としてあんちょく？ですが
毎回新しいテンプレートで作業するのはいかがでしょうか。

Public Sub Sample2()
Dim app As Object
Dim avdoc As Object
Dim pddoc As Object
Dim i As Long
Const PDSaveFull = 1
Const PdfFilePath As String = "C:\Files\template.pdf" 'PDFファイルのパス

Set app = CreateObject("AcroExch.App")
Set avdoc = CreateObject("AcroExch.AVDoc")
For i = 2 To ActiveSheet.Range("A1").End(xlDown).Row
　If avdoc.Open(PdfFilePath, "") = True Then
　　app.Show 'Acrobat表示
　　Set pddoc = avdoc.GetPDDoc
　　With pddoc.GetJSObject
　　　.getField("fldName").Value = CStr(ActiveSheet.Cells(i, 1).Value)
　　　.getField("fldAge").Value = CStr(ActiveSheet.Cells(i, 2).Value)
　　　.getField("fldAddress").Value = CStr(ActiveSheet.Cells(i, 3).Value)
　　　pddoc.Save PDSaveFull, "C:\Files\MyPDF_" & i - 1 & ".pdf" 'PDFファイルを別名保存
　　End With
　　avdoc.Close 1 '文書を保存せずに閉じる
　End If
Next
app.Hide: app.Exit
End Sub

・ツリー全体表示


	【81593】可視セルの値をクリップボードに格納する...

コウジ - 21/1/15(金) 15:53 -


	引用なし

	パスワード

オートフィルタでフィルタリングされたD列の値をクリップボードに格納したいのですが、
下記のコードだと１行だけしか格納されません。どうしたらよいでしょうか？

Dim d　　　　　 As Long　　　　　　
Dim n　　　　　 As Long　　　　　　
Dim i　　　　　 As Range　　　　　　
Dim clipboard　 As New DataObject　

d = Day(Date)

Set i = Range("9:9").Find(d, LookAt:=xlWhole, SearchOrder:=xlByColumns)

n = Range(i.Address).Column

ActiveSheet.AutoFilterMode = False

Range("9:9").autofilter

Range(i.Address).autofilter n, RGB(81, 216, 255), xlFilterCellColor

With clipboard
　　.SetText Range(Range("D10"), Range("d" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
　　.PutInClipboard　　　　　　
　　.GetFromClipboard　　　　　
End With

・ツリー全体表示


	【81592】PDFへのデータ差し込み

junhoshi - 21/1/14(木) 10:20 -


	引用なし

	パスワード

81584で質問させていただいたのですが解決せず再度投稿です。

81584ではラジオボタン操作も質問したのですが、ここでは0から始まる数字の差し込みお聞きしたいです。

以下は他のサイトで投稿した内容です。（こちらも回答がついていません）

PDFファイルにエクセルデータを差し込み、印刷せず、別名でPDFファイルを保存するVBAマクロを知りたく下記の文をサイトで見つけたのですが、これに001から始まる通番を追加したいのですがうまくいきません。

エクセル側はD列に通番（001~005）を、PDFファイルにフィールド名：通番を、構文は
.getField("fldAddress").Value = CStr(ActiveSheet.Cells(i, 3).Value)
の下に
.getField("通番").Value = CStr(ActiveSheet.Cells(i, 4).Value)
を追加しました。

実行すると、最初は001になるのですが以降は2,3,4,5と頭の00が省略されてしまいます。

元の構文です。
（エクセルデータはA列：氏名、B列：年齢、C列：住所です）

対象となるPDFファイルには下図のように氏名(フィールド名:fldName)、年齢(フィールド名:fldAge)、住所(フィールド名:fldAddress)の3つのフィールドがあり、
下図のようなセルA2 – C6までの値を差し込むことを想定しています。

※ 動作確認はWindows 7 + Acrobat XI環境で行いました。

Public Sub Sample2()
Dim app As Object
Dim avdoc As Object
Dim pddoc As Object
Dim i As Long
Const PDSaveFull = 1
Const PdfFilePath As String = "C:\Files\template.pdf" 'PDFファイルのパス

Set app = CreateObject("AcroExch.App")
Set avdoc = CreateObject("AcroExch.AVDoc")
If avdoc.Open(PdfFilePath, "") = True Then
app.Show 'Acrobat表示
Set pddoc = avdoc.GetPDDoc
With pddoc.GetJSObject
For i = 2 To ActiveSheet.Range("A1").End(xlDown).Row
.getField("fldName").Value = CStr(ActiveSheet.Cells(i, 1).Value)
.getField("fldAge").Value = CStr(ActiveSheet.Cells(i, 2).Value)
.getField("fldAddress").Value = CStr(ActiveSheet.Cells(i, 3).Value)
pddoc.Save PDSaveFull, "C:\Files\MyPDF_" & i - 1 & ".pdf" 'PDFファイルを別名保存
Next
End With
avdoc.Close 1 '文書を保存せずに閉じる
app.Hide: app.Exit
End If
End Sub

ちなみに同じような質問がされていたのですが
Set pddoc = avdoc.GetPDDoc
With pddoc.GetJSObject
上記2行をループ内に入れることによって自己解決したとのことでしたが具体的にどのようにされたのかがわからず投稿させていただくことになってしまいました。

どうかよろしくお願い致します。

・ツリー全体表示


	【81591】Re:オートフィルターのON OFFについて

ken - 21/1/13(水) 12:07 -


	引用なし

	パスワード

BJさん

解決しました。
モードで区別すれば良いんですね。
勉強になりました。
ありがとうございました。

・ツリー全体表示


	【81590】Re:オートフィルターのON OFFについて

BJ - 21/1/12(火) 2:02 -


	引用なし

	パスワード

If ActiveSheet.AutoFilterMode Then
　 MsgBox "オートフィルタ状態"
　 If ActiveSheet.AutoFilter.FilterMode Then　　'←（注）2007以上
　　　MsgBox "絞り込まれています"
　　　'ActiveSheet.ShowAllData
　 Else
　　　MsgBox "絞り込まれていません"
　 End If
Else
　 MsgBox "オートフィルタ状態ではない"
End If

・ツリー全体表示


	【81589】オートフィルターのON OFFについて

ken - 21/1/6(水) 15:10 -


	引用なし

	パスワード

いつもお世話になっております。
オートフィルターのONとOFFを下記の様にコードを書いてそれぞれボタンを
割り当てています。これを一つのボタンでON OFFを切り替える様にするには
どうしたら良いのでしょうか？

Sub Filter_On()
　　With Range("$A$5:$AC$1000")
　　　　.AutoFilter field:=4, Criteria1:="<>"
　　　　.AutoFilter field:=5, Criteria1:="<>"
　　End With
End Sub

Sub Filter_off()
　　Dim i As Long
　　
　　With ActiveSheet
　　　　For i = 1 To .AutoFilter.Filters.Count
　　　　　　If .AutoFilter.Filters(i).On Then
　　　　　　　　.AutoFilter.ShowAllData
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　End With
End Sub

・ツリー全体表示


	【81587】Re:PDFへのデータ差し込み

junhoshi - 21/1/5(火) 12:48 -


	引用なし

	パスワード

やはり２行目からの通番の最初の「0」または「00」は削除されてしまいます。

・ツリー全体表示


	【81586】Re:PDFへのデータ差し込み

［名前なし］ - 20/12/31(木) 16:41 -


	引用なし

	パスワード

CStr(ActiveSheet.Cells(i, 1).Value)
の数値から文字がダメでしたら

ActiveSheet.Cells(i, 1).Text　
とテキストとして受け取ればどうなりますか？

・ツリー全体表示


	【81585】Re:Msgboxを表示中に、別のExcelブックを...

稲垣 - 20/12/30(水) 12:18 -


	引用なし

	パスワード

▼OK さん：
>ユーザーフォームなどで作ったMsgBoxのようなもの
>ではなくMsgBoxに拘る理由は何ですか？
>
>基本的にMsgBox表示中は他の捜査は出来ない
>ことは常識なので、そこを敢えてやりたい理由を教え
>てください。
ご返信・ご教授ありがとうございます。
MsgBox表示中は他の操作は出来ない旨、承知致しました。

既にMsgBoxを使用してプログラムを作り込んでしまったため、
MsgBoxを表示中に他の操作ができたらよいと考えていました。

ユーザーフォームを使用する方向で考え直してみます。

・ツリー全体表示


	【81584】PDFへのデータ差し込み

junhoshi - 20/12/29(火) 17:23 -


	引用なし

	パスワード

ＰＤＦで配布されているフォーマットにエクセルで整理したデータを差し込むのに初心者ながら挑戦していますが行き詰ってしまいました。

お聞きしたいのは２点。

１つめは文字列で入力した001から始まる数字３桁の差し込み。
サイトで下記の構文をみつけ「text」フィールドに差し込むと１行目は「001」になるのですが２行目以降は頭の「00」または「0」が省略され結果は「2」または「10」のようになってしまいます。

Public Sub Sample2()
　Dim app As Object
　Dim avdoc As Object
　Dim pddoc As Object
　Dim i As Long
　Const PDSaveFull = 1
　Const PdfFilePath As String = "C:\Files\template.pdf" 'PDFファイルのパス
　
　Set app = CreateObject("AcroExch.App")
　Set avdoc = CreateObject("AcroExch.AVDoc")
　If avdoc.Open(PdfFilePath, "") = True Then
　　app.Show 'Acrobat表示
　　Set pddoc = avdoc.GetPDDoc
　　With pddoc.GetJSObject
　　　For i = 2 To ActiveSheet.Range("A1").End(xlDown).Row
　　　　.getField("text").Value = CStr(ActiveSheet.Cells(i, 1).Value)
　　　　pddoc.Save PDSaveFull, "C:\Files\MyPDF_" & i - 1 & ".pdf" 'PDFファイルを別名保存
　　　Next
　　End With
　　avdoc.Close 1 '文書を保存せずに閉じる
　　app.Hide: app.Exit
　End If
End Sub

２つめは上記の構文に性別を選択するラジオボタンを操作する処理を加えたいです。

With avdoc.GetPDDoc.GetJSObject
　　　.getField("Radio Button1").Value = "女" '性別

　　End With

これを上記の構文に加え、女のラジオボタンを操作することはできたのですが、エクセルの２列目に性別を「男」or「女」で入力、しこのデータをもとにラジオボタンを操作する方法がわかりません。また上記構文のどこに加えたらよいのかもご教授ねがえるとありがたいです。

・ツリー全体表示


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

44 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free