end-u の回答履歴

いつも、お世話になります。 ファイルはネットワークサーバー内にあるファイルへリンクさせ作成したデータ表です。 リンク内容はSUM＋OFFSETによる集計をさせてます。 リンクは同時に開いた状態で更新されます。 データが更新された時点で上書き保存します。 その後、ファイルを単独で開くとリンク更新する・しないの画面になりますが、する・しないのどちらを選択してもリンク部分のセルがVALUEになってしまいます。（更新画面の背景は前回保存したデータは表示しています） 再び、リンク先を開けばリンク値は表示しますが・・・ 更新しないを選択でVALUEになるのはなぜ？（設定がおかしいのか？） 判る方、教えて下さい。

今回パソコンをVistaに更新しました。 excel2000で使っていたソフトを2007に移植して使用したところ、マクロが非常に遅くなった気がします。 パソコンは以前のものはペンティアム4の3..4GHZ、今度のものはCore 2 Quad Q9550です。 性能的には格段に優れているはずなのに、合点がいきません。 こうなる理由が分かりましたら、教えてください。

今回パソコンをVistaに更新しました。 excel2000で使っていたソフトを2007に移植して使用したところ、マクロが非常に遅くなった気がします。 パソコンは以前のものはペンティアム4の3..4GHZ、今度のものはCore 2 Quad Q9550です。 性能的には格段に優れているはずなのに、合点がいきません。 こうなる理由が分かりましたら、教えてください。

先日ここで、セレクトせずに貼り付ける方法を、「コピーメソッドにDestinationプロパティを設定すれば実行することができる」と言うことを教えて頂きました。 Selection.Copy Destination:=Sheets(2).Range("Z59:AG97") 今度は同じようにセレクト（画面が切り替わらない）せずに、リンク貼り付けを行いたいのです。自分なりにアレコレ試してみましたが、如何しても上手くできません。どのようにすればいいのでしょうか？ よろしくお願い致します。

タイトルのとおりなのですが、セル範囲を選択した状態で Ctrl+C とすると、その範囲がクリップボードにコピーされると同時に破線で囲まれてチラチラした状態になりますが、このチラチラしている範囲をVBA内で知る方法を教えて下さい。Rangeオブジェクトとか、セル座標などを取得する方法です。 念のため補足しますが、このチラチラ状態で別の領域を選択すると、破線チラチラ領域を維持したまま、別の領域を選択できますが、つまり、破線チラチラ領域とセル選択領域の２つの領域を指定している状態になりますが、このときのチラチラ領域の方を知る方法です。 よろしくお願いします。

Sub 自動グラフ作成() For i = 5 To 32 Step 3 Charts.Add ActiveChart.ChartType = xlXYScatterSmoothNoMarkers ActiveChart.SeriesCollection.NewSeries ActiveChart.SeriesCollection(1).XValues = "=distance!R18C1:R1009C1" ActiveChart.SeriesCollection(1).Values = "=distance!R18C" & (i + 2) & ":R1009C" & (i + 2) Next End Sub 上記のように表の中の決められたセルからデータを取り出して自動的にグラフを作成してくれるマクロを作成したのですが、奇数個めのグラフは正常に生成されるのですが、偶数個めのグラフになぜか x= y=distance!$M$18:$M$1009 x= y={1} みたいな必要なグラフ以外に上記の２つのグラフを混じってしまいます。これってどこがおかしいのでしょうか？ どなたか助けて下さい。 お願いいたします。

Sub 自動グラフ作成() For i = 5 To 32 Step 3 Charts.Add ActiveChart.ChartType = xlXYScatterSmoothNoMarkers ActiveChart.SeriesCollection.NewSeries ActiveChart.SeriesCollection(1).XValues = "=distance!R18C1:R1009C1" ActiveChart.SeriesCollection(1).Values = "=distance!R18C" & (i + 2) & ":R1009C" & (i + 2) Next End Sub 上記のように表の中の決められたセルからデータを取り出して自動的にグラフを作成してくれるマクロを作成したのですが、奇数個めのグラフは正常に生成されるのですが、偶数個めのグラフになぜか x= y=distance!$M$18:$M$1009 x= y={1} みたいな必要なグラフ以外に上記の２つのグラフを混じってしまいます。これってどこがおかしいのでしょうか？ どなたか助けて下さい。 お願いいたします。

Excel　2007のマクロ記録は、詳細はできないのでしょうか。 Excel　2000では、かなり詳細まで記述してくれますが、Excel　2007で同じことを 行っても、記述がありません。グラフの枠や、色などを変えるマクロを試してみましたが、記述されませんでした。 　なにか、設定が不足しているのでしょうか このままだと、Excel　20007はVBAが使えないマクロとなりそうです。 どなたか、ご存じの方ご指導をお願いいたします。 　マイクロソフトに問い合わせたら、有償相談だそうです。詳細内容を聞くのではなく、Excel2000と同じかどうか聞くだけでもですって。理不尽だと思います。

タイトルのとおりなのですが、セル範囲を選択した状態で Ctrl+C とすると、その範囲がクリップボードにコピーされると同時に破線で囲まれてチラチラした状態になりますが、このチラチラしている範囲をVBA内で知る方法を教えて下さい。Rangeオブジェクトとか、セル座標などを取得する方法です。 念のため補足しますが、このチラチラ状態で別の領域を選択すると、破線チラチラ領域を維持したまま、別の領域を選択できますが、つまり、破線チラチラ領域とセル選択領域の２つの領域を指定している状態になりますが、このときのチラチラ領域の方を知る方法です。 よろしくお願いします。

こんにちは。今、学校の卒業研究でVB（ver２００５)でウェブブラウザを作っています。マウスジェスチャ機能を実装したいのですが、全くわからないので、どなたか教えていただけないでしょうか？よろしくお願いします。

仕事でエクセルを使う事が多く、特に列、行がたくさんある一覧を表を日常業務で使っています。そこで選択セルの行全体が色付けされるような仕組みを作りたく。（イメージ的には、今触っているセルがどの行なのか目で追い易くする感じです）このようなマクロを作りました。ただ、これでは元々色が付いているセルの色が、色無しに変化してしまう為、使えません。使っている表の元々の色を変化させずに、色で簡単に行全体を目で追えるようにするにはどうしたら良いでしょうか？本当に申し訳ないですが、わかる方いらっしゃいましたら、ご教授お願い致します。 Public m Private Sub Worksheet_SelectionChange(ByVal Target As Range) 　If m <> 0 Then 　　Range(Cells(m, 1), Cells(m, 256)).Interior.ColorIndex = xlNone 　End If 　Range(Cells(Target.Row, 1), Cells(Target.Row, 256)).Interior.ColorIndex = 6 　m = Target.Row End Sub

Sub 百人一首一番から二十番() Dim hyakuSh As Worksheet Dim mySh As Worksheet Set mySh = Worksheets("百人一首クイズ") Set hyakuSh = Worksheets("百人一首") Dim myRow As Integer Randomize myRow = Int((21 - 2 + 1) * Rnd + 2) Dim kaminoku As String Dim kaminoku2 As String Dim kaminoku3 As String Dim simonoku As String Dim simonoku1 As String Dim sakusha As String kaminoku = hyakuSh.Cells(myRow, 3).Value kaminoku2 = hyakuSh.Cells(myRow, 4).Value kaminoku3 = hyakuSh.Cells(myRow, 5).Value shimonoku = hyakuSh.Cells(myRow, 6).Value shimonoku1 = hyakuSh.Cells(myRow, 7).Value sakusha = hyakuSh.Cells(myRow, 8).Value mySh.Activate mySh.Shapes("Text Box 2").Select Selection.Characters.Text = kaminoku & Chr(10) & kaminoku2 & Chr(10) & kaminoku3 Dim MyTBox As Integer Dim smRow As Integer Dim smRow2 As Integer Dim smRow3 As Integer Dim smRow4 As Integer Dim smRow5 As Integer Dim i As Integer mySh.Shapes(2).Select Randomize smRow5 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow5, 6).Value & Chr(10) & hyakuSh.Cells(smRow5, 7).Value & Chr(10) & hyakuSh.Cells(smRow5, 8).Value mySh.Shapes(3).Select Randomize smRow = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow, 6).Value & Chr(10) & hyakuSh.Cells(smRow, 7).Value & Chr(10) & hyakuSh.Cells(smRow, 8).Value mySh.Shapes(4).Select Randomize smRow2 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow2, 6).Value & Chr(10) & hyakuSh.Cells(smRow2, 7).Value & Chr(10) & hyakuSh.Cells(smRow2, 8).Value mySh.Shapes(5).Select Randomize smRow3 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow3, 6).Value & Chr(10) & hyakuSh.Cells(smRow3, 7).Value & Chr(10) & hyakuSh.Cells(smRow3, 8).Value mySh.Shapes(6).Select Randomize smRow4 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow4, 6).Value & Chr(10) & hyakuSh.Cells(smRow4, 7).Value & Chr(10) & hyakuSh.Cells(smRow4, 8).Value Randomize MyTBox = Int((6 - 2 + 1) * Rnd + 2) mySh.Shapes(MyTBox).Select Selection.Characters.Text = shimonoku & Chr(10) & shimonoku1 & Chr(10) & sakusha mySh.Shapes("Text Box 2").Select Dim Ans As Integer Ans = InputBox(hyakuSh.Cells(myRow, 3).Value & hyakuSh.Cells(myRow, 4).Value & hyakuSh.Cells(myRow, 5).Value & Chr(10) & Chr(10) & "下の句を番号で答えなさい", Title:="百人一首", Xpos:=7500, Ypos:=2500) If Ans = MyTBox Then MsgBox " 正解!!! V(・ o ・)V " Else MsgBox ("間違いです!!!!!!!!" & Chr(10) & Chr(10) & hyakuSh.Cells(myRow, 6).Value & hyakuSh.Cells(myRow, 7).Value & Chr(10) & Chr(10) & sakusha & "です") End If End Sub 以上のマクロをエクセルで作ったのですが、VBE～マクロを走らせると順調に走るのですが、マクロをボタンに登録すると、Inputbox に解答を掘り込んであげないと、kaminokuもshimonokuもあたらしいものになりません 今マクロはシート上にあります、マクロを標準モジュールに移しても同じ結果です。何か解決策はありますか? かなり古くエクセル2000です、初心者なので難しいこことはわかりませんが、よろしくお願いします。

Sub 百人一首一番から二十番() Dim hyakuSh As Worksheet Dim mySh As Worksheet Set mySh = Worksheets("百人一首クイズ") Set hyakuSh = Worksheets("百人一首") Dim myRow As Integer Randomize myRow = Int((21 - 2 + 1) * Rnd + 2) Dim kaminoku As String Dim kaminoku2 As String Dim kaminoku3 As String Dim simonoku As String Dim simonoku1 As String Dim sakusha As String kaminoku = hyakuSh.Cells(myRow, 3).Value kaminoku2 = hyakuSh.Cells(myRow, 4).Value kaminoku3 = hyakuSh.Cells(myRow, 5).Value shimonoku = hyakuSh.Cells(myRow, 6).Value shimonoku1 = hyakuSh.Cells(myRow, 7).Value sakusha = hyakuSh.Cells(myRow, 8).Value mySh.Activate mySh.Shapes("Text Box 2").Select Selection.Characters.Text = kaminoku & Chr(10) & kaminoku2 & Chr(10) & kaminoku3 Dim MyTBox As Integer Dim smRow As Integer Dim smRow2 As Integer Dim smRow3 As Integer Dim smRow4 As Integer Dim smRow5 As Integer Dim i As Integer mySh.Shapes(2).Select Randomize smRow5 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow5, 6).Value & Chr(10) & hyakuSh.Cells(smRow5, 7).Value & Chr(10) & hyakuSh.Cells(smRow5, 8).Value mySh.Shapes(3).Select Randomize smRow = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow, 6).Value & Chr(10) & hyakuSh.Cells(smRow, 7).Value & Chr(10) & hyakuSh.Cells(smRow, 8).Value mySh.Shapes(4).Select Randomize smRow2 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow2, 6).Value & Chr(10) & hyakuSh.Cells(smRow2, 7).Value & Chr(10) & hyakuSh.Cells(smRow2, 8).Value mySh.Shapes(5).Select Randomize smRow3 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow3, 6).Value & Chr(10) & hyakuSh.Cells(smRow3, 7).Value & Chr(10) & hyakuSh.Cells(smRow3, 8).Value mySh.Shapes(6).Select Randomize smRow4 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow4, 6).Value & Chr(10) & hyakuSh.Cells(smRow4, 7).Value & Chr(10) & hyakuSh.Cells(smRow4, 8).Value Randomize MyTBox = Int((6 - 2 + 1) * Rnd + 2) mySh.Shapes(MyTBox).Select Selection.Characters.Text = shimonoku & Chr(10) & shimonoku1 & Chr(10) & sakusha mySh.Shapes("Text Box 2").Select Dim Ans As Integer Ans = InputBox(hyakuSh.Cells(myRow, 3).Value & hyakuSh.Cells(myRow, 4).Value & hyakuSh.Cells(myRow, 5).Value & Chr(10) & Chr(10) & "下の句を番号で答えなさい", Title:="百人一首", Xpos:=7500, Ypos:=2500) If Ans = MyTBox Then MsgBox " 正解!!! V(・ o ・)V " Else MsgBox ("間違いです!!!!!!!!" & Chr(10) & Chr(10) & hyakuSh.Cells(myRow, 6).Value & hyakuSh.Cells(myRow, 7).Value & Chr(10) & Chr(10) & sakusha & "です") End If End Sub 以上のマクロをエクセルで作ったのですが、VBE～マクロを走らせると順調に走るのですが、マクロをボタンに登録すると、Inputbox に解答を掘り込んであげないと、kaminokuもshimonokuもあたらしいものになりません 今マクロはシート上にあります、マクロを標準モジュールに移しても同じ結果です。何か解決策はありますか? かなり古くエクセル2000です、初心者なので難しいこことはわかりませんが、よろしくお願いします。

　　　A　　　B　　　C　　　D　　　E　　　　←シート元 1　大区分　中区分　金額1　金額2　小区分　　←見出し行です。 2　　A社　管理課　12000　　3000　 1 3　　B社　総務課　10000　　2000　 1 4　　C社　業務課　 800 1000 　　 3 5　　A社　総務課　　　　　　　　　　　5 6　　C社　製造課　 600 5000　　　　2 7　　A社　製造課　15000 　　　　　　　1 8　　A社　管理課　 300 　　　　　　1 9　　B社　管理課　 800 2000　　　　　4 10　 D社　総務課　90000 9000　　　　　1 を大区分　中区分　小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが（下記のように　金額1　金額2ごとに足し算） 　　　A　　　B　　　C　　　D　　　E　　　　←シート集計 1　大区分　中区分　小区分金額1　金額2　　　←見出し位置変更 2　　A社　管理課　　1 12000 3300 3　　A社　総務課　　5　　 4　　A社　製造課　　1 15000　　 5　　B社　総務課　　1 10000 2000 6　　B社　管理課　　4 8000 2000 以下省略 実際に作りたいものは、元シートの金額の項目が多いのです（列が飛び飛びに40位あります）今回の例でいえばCとDが　CからF　HからV　ABからCHとなりそれぞれ金額3,4,5～50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。 Sub 3keyと2要素() ’実際は40要素くらいある Dim OLDBOOK As Workbook Dim SH1 As Worksheet Dim SH2 As Worksheet Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3, myVal4, myVal5 Dim i As Long Set OLDBOOK = ThisWorkbook Set SH1 = OLDBOOK.Worksheets("元") Set SH2 = OLDBOOK.Worksheets("集計") SH2.Cells.ClearContents SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value SH2.Range("C1").Value = SH1.Range("E1").Value SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") SH1.Select myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next myKey = myDic.keys ' 書き出し　とりあえず2要素 　　myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 1).Value = myVal3(0) SH2.Cells(i + 2, 2).Value = myVal3(1) SH2.Cells(i + 2, 3).Value = myVal3(2) SH2.Cells(i + 2, 4).Value = myItem(i) Next Set myDic = Nothing '******** Set myDic = CreateObject("Scripting.Dictionary") myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 4) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 4) End If End If Next myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 5).Value = myItem(i) Next Set myDic = Nothing ' 以下繰り返しするしかなく困ってます SH2.Select SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("AF2"), Order1:=xlAscending, _ Key2:=Range("B"), Order2:=xlAscending, _ Key3:=Range("C2"), Order3:=xlAscending, _ Header:=xlGuess Set OLDBOOK = Nothing Set SH1 = Nothing Set SH2 = Nothing End Sub

　　　A　　　B　　　C　　　D　　　E　　　　←シート元 1　大区分　中区分　金額1　金額2　小区分　　←見出し行です。 2　　A社　管理課　12000　　3000　 1 3　　B社　総務課　10000　　2000　 1 4　　C社　業務課　 800 1000 　　 3 5　　A社　総務課　　　　　　　　　　　5 6　　C社　製造課　 600 5000　　　　2 7　　A社　製造課　15000 　　　　　　　1 8　　A社　管理課　 300 　　　　　　1 9　　B社　管理課　 800 2000　　　　　4 10　 D社　総務課　90000 9000　　　　　1 を大区分　中区分　小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが（下記のように　金額1　金額2ごとに足し算） 　　　A　　　B　　　C　　　D　　　E　　　　←シート集計 1　大区分　中区分　小区分金額1　金額2　　　←見出し位置変更 2　　A社　管理課　　1 12000 3300 3　　A社　総務課　　5　　 4　　A社　製造課　　1 15000　　 5　　B社　総務課　　1 10000 2000 6　　B社　管理課　　4 8000 2000 以下省略 実際に作りたいものは、元シートの金額の項目が多いのです（列が飛び飛びに40位あります）今回の例でいえばCとDが　CからF　HからV　ABからCHとなりそれぞれ金額3,4,5～50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。 Sub 3keyと2要素() ’実際は40要素くらいある Dim OLDBOOK As Workbook Dim SH1 As Worksheet Dim SH2 As Worksheet Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3, myVal4, myVal5 Dim i As Long Set OLDBOOK = ThisWorkbook Set SH1 = OLDBOOK.Worksheets("元") Set SH2 = OLDBOOK.Worksheets("集計") SH2.Cells.ClearContents SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value SH2.Range("C1").Value = SH1.Range("E1").Value SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") SH1.Select myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next myKey = myDic.keys ' 書き出し　とりあえず2要素 　　myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 1).Value = myVal3(0) SH2.Cells(i + 2, 2).Value = myVal3(1) SH2.Cells(i + 2, 3).Value = myVal3(2) SH2.Cells(i + 2, 4).Value = myItem(i) Next Set myDic = Nothing '******** Set myDic = CreateObject("Scripting.Dictionary") myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 4) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 4) End If End If Next myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 5).Value = myItem(i) Next Set myDic = Nothing ' 以下繰り返しするしかなく困ってます SH2.Select SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("AF2"), Order1:=xlAscending, _ Key2:=Range("B"), Order2:=xlAscending, _ Key3:=Range("C2"), Order3:=xlAscending, _ Header:=xlGuess Set OLDBOOK = Nothing Set SH1 = Nothing Set SH2 = Nothing End Sub

　　　A　　　B　　　C　　　D　　　E　　　　←シート元 1　大区分　中区分　金額1　金額2　小区分　　←見出し行です。 2　　A社　管理課　12000　　3000　 1 3　　B社　総務課　10000　　2000　 1 4　　C社　業務課　 800 1000 　　 3 5　　A社　総務課　　　　　　　　　　　5 6　　C社　製造課　 600 5000　　　　2 7　　A社　製造課　15000 　　　　　　　1 8　　A社　管理課　 300 　　　　　　1 9　　B社　管理課　 800 2000　　　　　4 10　 D社　総務課　90000 9000　　　　　1 を大区分　中区分　小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが（下記のように　金額1　金額2ごとに足し算） 　　　A　　　B　　　C　　　D　　　E　　　　←シート集計 1　大区分　中区分　小区分金額1　金額2　　　←見出し位置変更 2　　A社　管理課　　1 12000 3300 3　　A社　総務課　　5　　 4　　A社　製造課　　1 15000　　 5　　B社　総務課　　1 10000 2000 6　　B社　管理課　　4 8000 2000 以下省略 実際に作りたいものは、元シートの金額の項目が多いのです（列が飛び飛びに40位あります）今回の例でいえばCとDが　CからF　HからV　ABからCHとなりそれぞれ金額3,4,5～50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。 Sub 3keyと2要素() ’実際は40要素くらいある Dim OLDBOOK As Workbook Dim SH1 As Worksheet Dim SH2 As Worksheet Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3, myVal4, myVal5 Dim i As Long Set OLDBOOK = ThisWorkbook Set SH1 = OLDBOOK.Worksheets("元") Set SH2 = OLDBOOK.Worksheets("集計") SH2.Cells.ClearContents SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value SH2.Range("C1").Value = SH1.Range("E1").Value SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") SH1.Select myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next myKey = myDic.keys ' 書き出し　とりあえず2要素 　　myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 1).Value = myVal3(0) SH2.Cells(i + 2, 2).Value = myVal3(1) SH2.Cells(i + 2, 3).Value = myVal3(2) SH2.Cells(i + 2, 4).Value = myItem(i) Next Set myDic = Nothing '******** Set myDic = CreateObject("Scripting.Dictionary") myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 4) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 4) End If End If Next myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 5).Value = myItem(i) Next Set myDic = Nothing ' 以下繰り返しするしかなく困ってます SH2.Select SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("AF2"), Order1:=xlAscending, _ Key2:=Range("B"), Order2:=xlAscending, _ Key3:=Range("C2"), Order3:=xlAscending, _ Header:=xlGuess Set OLDBOOK = Nothing Set SH1 = Nothing Set SH2 = Nothing End Sub

こんばんは。マクロの自動記録を使って、ピボットテーブルを作成したのですが、記録した時のシート名とデータ範囲で記録されてしまいます。アクティブシートのデータがある範囲をピボットテーブルにしたい時は、どうすれば良いでしょうか？ 以下のコードが自動記録で作成したコードです。 ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ "シート名!R1C1:R1000C30").CreatePivotTable TableDestination:= _ "", TableName:="ピボットテーブル2", DefaultVersion:=xlPivotTableVersion10 ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1) ActiveSheet.Cells(3, 1).Select With ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("商品番号") .Orientation = xlRowField .Position = 1 End With With ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("商品名　") .Orientation = xlRowField .Position = 2 End With Range("A9").Select ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("商品番号").Subtotals = Array( _ False, False, False, False, False, False, False, False, False, False, False, False) ActiveSheet.PivotTables("ピボットテーブル2").AddDataField ActiveSheet.PivotTables( _ "ピボットテーブル2").PivotFields("数量　"), "データの個数 / 数量　", xlCount With ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("発送日　") .Orientation = xlPageField .Position = 1 End With Range("A1").Select ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("発送日　").Orientation = _ xlHidden With ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("希望時期") .Orientation = xlColumnField .Position = 1 End With

お世話になります。 excel vba でマウスポインタの変更を教えてほしいのですが、「Application.Cursor」で使用可能な 　・xlDefault 　・xlNorthwestArrow 　・xlIBeam　 　・xlWait 以上の４つではなく、クロス型(＋のような形)のポインタに変更することはできないでしょうか？ 図形をコピー⇒貼り付けするタイミングでこのマウスポインタ型に変更できたらと思っています。 windowsAPIを使用した下記の方法では、一時的には可能ですが、マウスポインタを動かすと元に戻ってしまいます。 書き方、使用方法など間違っているのでしょうか。 -----winAPIを使用したソース--------------------------------------------------------- Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long Private Const IDC_CROSS = 32515& Sub CursorChangeTest() Dim i As Double Dim waitTime As Variant SetCursor (LoadCursor(0, IDC_CROSS)) 'ループ処理 For i = 1 To 5 waitTime = Now + TimeValue("0:00:01") Debug.Print "きました " & i Application.Wait waitTime Next i End Sub ------------------------------------------------------------------------------------ よろしくお願いします。

ヤフーファイナンスで銘柄毎に時系列データが公開されていますが、 次のデータをエクセル上に取得するマクロの作り方を教えてください。 最も最近の高値とここ３０日(３０回ではないです)の出来高の最高値です。 例えばＡの列に銘柄のコードが並べておきます。 他の列は空白です。 A B C・・・ 2914 7203 9432 マクロを実行するとBとCの列にヤフーファイナスから取得した値を出力して欲しいです。 A B C・・・ 2914 2914の銘柄の高値 2914の銘柄の30日の出来高の最高値 7203 7203の銘柄の高値 7203の銘柄の30日の出来高の最高値 9432 9432の銘柄の高値 9432の銘柄の30日の出来高の最高値 どなたか詳しい方おられましたら教えてください。

Sub プロダクトIDを表示する() バージョン = Application.Version 一意識別子 = Application.ProductCode レジストリキー = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\" _ & バージョン & "\Registration\" & 一意識別子 & "\ProductID" プロダクトID = CreateObject("WScript.Shell").RegRead(レジストリキー) MsgBox プロダクトID, , "プロダクトID" End Sub この様なコードを発見しました プロダクトIDを使って　エクセルが起動した時にプロダクトIDを検出して保存しておいて　このプロダクトIDと違ったもので起動した時に開かないように　　　そんな事が実現できますでしょうか　ご指南ください