Excel VBA質問箱 IV

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

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


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

226 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【77927】Re:VBAによるデータ抽出等について

β - 16/2/14(日) 9:26 -


	引用なし

	パスワード

▼マナさん：

なるほど、簡潔かつ効率がいいですねぇ。

ところで、きっと D列が赤でE列が青なんでしょうかね。

・ツリー全体表示


	【77926】Re:VBAによるデータ抽出等について

マナ - 16/2/14(日) 0:27 -


	引用なし

	パスワード

▼株太郎さん：
こんな風に考えてみました

１）データシートを新規ブックにコピー
２）高値が色付きセルなら、安値セルをクリアし、H列に行番号をセット
３）安値が色付きセルなら、高値セルをクリアし、H列に行番号をセット
４）H列が空白の行をオートフィルタで抽出し削除
５）H列の値から、セルの個数を計算（I列）
６）不要な列を削除

Sub test()
　　Dim i As Long
　　
　　Sheets("Sheet1").Copy　　'★データシート
　　
　　With ActiveSheet.Cells(1).CurrentRegion.Columns("A:H")
　　　　For i = 2 To .Rows.Count
　　　　　　If .Cells(i, "D").Interior.Color = vbBlue Then
　　　　　　　　.Cells(i, "E").ClearContents
　　　　　　　　.Cells(i, "H").Value = i
　　　　　　ElseIf .Cells(i, "E").Interior.Color = vbRed Then
　　　　　　　　.Cells(i, "D").ClearContents
　　　　　　　　.Cells(i, "H").Value = i
　　　　　　End If
　　　　Next

　　　　.AutoFilter
　　　　.AutoFilter Field:=8, Criteria1:="="
　　　　.Offset(1).EntireRow.Delete
　　　　.AutoFilter
　　　　.Interior.Color = xlNone

　　　　If .Rows.Count > 1 Then
　　　　　　With .Columns("I").Resize(.Rows.Count - 1).Offset(1)
　　　　　　　　.FormulaR1C1 = "=IF(R[-1]C[-1]="""","""",RC[-1]-R[-1]C[-1])"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　End If
　　　　.Cells(1, "I").Value = "セルの個数"
　　　　.Columns("F:H").Delete
　　　　.Columns("B:C").Delete
　　　　.Cells(1).Select
　　End With
　　　　　　
End Sub

・ツリー全体表示


	【77925】Re:VBAによるデータ抽出等について

β - 16/2/13(土) 19:42 -


	引用なし

	パスワード

▼株太郎さん：

株のことは詳しくないのですが、アップされたレイアウトと説明から推測して。
元シートが "Sheet1"、転記シートが "Sheet2" 。　
転記シート側のタイトルはあらかじめセットしてあるという前提です。

また、【赤】とか【青】ですけど、★印のところは、シート上に塗ってある実際の色番号に
直してください。

Sub Sample()
　　Dim red As Range
　　Dim blue As Range
　　Dim fR As Range
　　Dim fB As Range
　　Dim eR As Range
　　Dim eB As Range
　　Dim flagRB As Boolean
　　Dim f As Range
　　Dim e As Range
　　Dim c As Range
　　Dim pre As Range
　　Dim myColor As Long
　　Dim i As Long
　　Dim shT As Worksheet
　　
　　Set shT = Sheets("Sheet2")　　　'転記シート
　　i = 2　　　　　　　　　　　　　 '転記開始行番号
　　
　　With Sheets("Sheet1")　　　　　 '元シート
　　　　Set fR = .Range("D1")
　　　　Set fB = .Range("E1")
　　　　Set eR = .Range("D" & Rows.Count).End(xlUp)
　　　　Set eB = .Range("E" & Rows.Count).End(xlUp)
　　End With
　　
　　Do
　　　　flagRB = Not flagRB
　　　　If flagRB Then
　　　　　　Set f = fR
　　　　　　Set e = eR
　　　　　　myColor = vbRed　　 '★
　　　　Else
　　　　　　Set f = fB
　　　　　　Set e = eB
　　　　　　myColor = vbBlue　　'★
　　　　End If
　　　　
　　　　Application.FindFormat.Interior.Color = myColor
　　　　Set c = Range(f, e).Find(What:="", After:=f, LookIn:=xlFormulas, LookAt:=xlPart, SearchFormat:=True)
　　　　If c Is Nothing Then Exit Do
　　　　
　　　　shT.Cells(i, "A").Value = c.EntireRow.Range("A1").Value　　　　 '日付
　　　　If flagRB Then
　　　　　　shT.Cells(i, "B").Value = c.EntireRow.Range("D1").Value　　 '高値
　　　　Else
　　　　　　shT.Cells(i, "C").Value = c.EntireRow.Range("E1").Value　　 '安値
　　　　End If
　　　　
　　　　If Not pre Is Nothing Then shT.Cells(i, "D").Value = c.Row - pre.Row
　　　　
　　　　i = i + 1
　　　　
　　　　
　　　　If c.Row = eR.Row Then Exit Do
　　　　
　　　　Set fR = c.EntireRow.Range("D1")
　　　　Set fB = c.EntireRow.Range("E1")
　　　　Set pre = c
　　Loop
　　　　
End Sub

・ツリー全体表示


	【77924】VBAによるデータ抽出等について

株太郎 - 16/2/13(土) 17:15 -


	引用なし

	パスワード

VBA初心者です。
データ処理をVBAで効率化したく色々調べてみましたが、
参考になるものを見つけ出せずに質問しました。

やりたいこと
・下記の株価データ（データ量は随時増加）からのデータ抽出
　抽出条件
　1.高値欄の色付けされたセルから、日付、高値欄の数値
　2.安値欄の色付けされたセルから、日付、安値欄の数値

・抽出されたデータ間にあるデータの個数を数える

■株価データ（わかり難いですが、数値ヨコの赤、青が色づけされたセルです）

日付　　　　　　時間　　　　始値　　高値　　安値　　　終値　　　　出来高
2015/12/30　　　14:05:00　　19060　　19070　 19060　　19060　　　　 94
2015/12/30　　　14:10:00　　19060　　19070赤 19060　　19060　　　　 59
2015/12/30　　　14:15:00　　19060　　19060　 19050　　 19060　　　　 31
2015/12/30　　　14:20:00　　19050　　19060　 19040　　 19050　　　　176
2015/12/30　　　14:25:00　　19050　　19060　 19040　　 19040　　　　115
2015/12/30　　　14:30:00　　19040　　19040　 19030　　 19030　　　　219
2015/12/30　　　14:35:00　　19040　　19040　 19030　　 19040　　　　 35
2015/12/30　　　14:40:00　　19040　　19040　 19020　　 19040　　　　296
2015/12/30　　　14:45:00　　19030　　19040　 19010　　 19010　　　　605
2015/12/30　　　14:50:00　　19020　　19030　 19010　　 19030　　　　333
2015/12/30　　　14:55:00　　19030　　19040　 19020　　 19040　　　　280
2015/12/30　　　15:00:00　　19040　　19040　 19010　　 19020　　　　849
2015/12/30　　　15:05:00　　19020　　19020　 19000　　 19010　　　　732
2015/12/30　　　15:10:00　　19010　　19010　 18980青　 19000　　　 2246
2015/12/30　　　16:35:00　　19010　　19020　 19010　　 19020　　　　392
2015/12/30　　　16:40:00　　19030　　19030赤 19030　　 19030　　　　107
2015/12/30　　　16:45:00　　19030　　19030　 19020　　 19020　　　　　8
2015/12/30　　　16:50:00　　19030　　19030　 19010　　 19010　　　　64
2015/12/30　　　16:55:00　　19010　　19020　 19010　　 19010　　　　 10
2015/12/30　　　17:00:00　　19020　　19020　 19020　　 19020　　　　 23
2015/12/30　　　17:05:00　　19020　　19020　 19000　　 19000　　　　287
2015/12/30　　　17:10:00　　19000　　19010　 19000　　 19000　　　　 80
2015/12/30　　　17:15:00　　19000　　19010　 19000　　 19000　　　　　6
2015/12/30　　　17:20:00　　19000　　19000　 18980青　 19000　　　　144
2015/12/30　　　17:25:00　　19000　　19020　 19000　　 19010　　　　 11　　
2015/12/30　　　17:30:00　　19010　　19010　 19000　　 19000　　　　 71

■完成系のイメージ
日付　　　　　　　高値　　　安値　セルの個数
2015/12/30　　　　19070
2015/12/30　　　　　　　　 18980　　　　　12
2015/12/30　　　　19030　　　　　　　　　　2
2015/12/30　　　　　　　　 18980　　　　　 8

以上、VBAの詳しい方、是非アドバイスを頂きたくよろしくお願いいたします。

・ツリー全体表示


	【77923】Re:検索

佐藤 - 16/2/7(日) 13:24 -


	引用なし

	パスワード

望みのコードがやっと見つかりました。
有難うございます。

・ツリー全体表示


	【77922】Re:検索

γ - 16/2/7(日) 11:24 -


	引用なし

	パスワード

横から失礼します。

Findメソッドの利用を薦められたのですから、
"Excel Findメソッド"　
などでネット検索すれば、お望みのコード例が見つかりませんか？

例えば、最初に出てくる
ht　tps://www.moug.net/tech/exvba/0050116.html
などはどうですか？

・ツリー全体表示


	【77921】Re:検索

佐藤 - 16/2/7(日) 10:11 -


	引用なし

	パスワード

ご教授ありがとうございます。
　

・ツリー全体表示


	【77920】Re:検索

佐藤 - 16/2/7(日) 10:08 -


	引用なし

	パスワード

ご教授ありがとうございます。
　条件1と条件2はクリアーできたのですが、
条件3がどうしてもクリアーできません。
以下に作ったコードのどこに付け加えたらよろしいのでしょうか？
具体的にコードを入力していただけないでしょうか？

　Private Sub CommandButton1_Click()
　　　 Dim sh As Object
　　　 Dim myCnt As Integer
　　　 Dim AllSu As Integer
　　　 Dim target As Variant
　　　 '＜検索結果保管先を初期化します。＞
　　　　 AllSu = 0
　　　 '＜検索する文字列を指定する入力用のダイアログボックスを表示
　　　　　します。＞
　　　 target = Application.InputBox(Prompt:="検索する文字を入力
　　　　して下　　さい。")
　　　　 '＜キャンセルか未入力ではなかったら検索します。＞
　　　 If target <> False And target <> "" Then '
　　　 '＜対象のシートを対象に検索を行います。＞
　　　　 For Each sh In ActiveWindow.SelectedSheets
　　　 '＜使われているセル範囲に含まれるセルのうち、
　　　 '検索条件に一致するセルの個数を取得します。＞
　　　　myCnt = WorksheetFunction.CountIf(sh.UsedRange, target) '
　　　　'＜検索条件に一致したセルの個数をカウントします。＞
　　　　AllSu = AllSu + myCnt
　　　　Next sh
　　　 '＜全てのシートの検索が終わったら、結果を表示します。＞
　　　　　 If AllSu = 0 Then
　　　　　　 MsgBox target & "は見つかりませんでした。"
　　　　　　　Else
　　　　　　　MsgBox target & "は" & AllSu & "個あります。"
　　　　　 End If
　　　　 End If
　　End Sub

以上　よろしくお願いします。

・ツリー全体表示


	【77919】Re:検索

ichinose - 16/2/6(土) 16:47 -


	引用なし

	パスワード

▼佐藤さん：
>エクセルvbaの初心者です。
>vbaで検索を行いたいのですが、なかなかうまくできません。
>どなたかくわしい方、教えていただけないでしょうか？
>　ただ、検索には以下のような条件があります。
Excelには、検索という機能がありますよね？
これの亜種版ですね！！

>　　条件1　ワークシート内で検索を行う
RangeオブジェクトにFindメソッド（FindNextメソッドとの組合せ）
を調べてください。二つのメソッドの共演コードなら、ごろごろしています。
入力データ　　検索セル範囲
　　　　　　　　　検索文字列

出力データ　　検索した結果、見つかったセル範囲

>　　条件2　検索対象をを対話式（メッセージボックス）で行う
　　検索文字列の入力は、ApplicationオブジェクトのInputboxメソッドを調べてください。

>　　条件3　検索でヒットしたセルを色（ピンク）で塗りつぶす
　　　将来的には、ピンクだけでなく色も自由に選べるようにすると便利そうですが、　セルに色を付けるのは、マクロの記録を使えば、容易にコードは生成されます

以上です。

・ツリー全体表示


	【77918】Re:検索

マナ - 16/2/6(土) 16:39 -


	引用なし

	パスワード

▼佐藤さん：
ここらを参考に試してみてはどうでしょうか。
ht　tp://excelwork.info/excel/cellreplacereplaceformat/
ht　tp://www.moug.net/tech/exvba/0010014.html

・ツリー全体表示


	【77917】検索

佐藤 - 16/2/6(土) 14:22 -


	引用なし

	パスワード

エクセルvbaの初心者です。
vbaで検索を行いたいのですが、なかなかうまくできません。
どなたかくわしい方、教えていただけないでしょうか？
　ただ、検索には以下のような条件があります。
　　条件1　ワークシート内で検索を行う
　　条件2　検索対象をを対話式（メッセージボックス）で行う
　　条件3　検索でヒットしたセルを色（ピンク）で塗りつぶす

以上よろしくお願い申し上げます。

・ツリー全体表示


	【77916】Re:選択セルをコピペ、印刷、コピーした...

マナ - 16/2/5(金) 23:44 -


	引用なし

	パスワード

Sub test()
　　Dim i As Long
　　
　　For i = 0 To 5
　　　　Range("d1:f1").Value = Range("a1:c1").Offset(i).Value
　　　　Range("d1:f1").PrintPreview
　　Next
　　
End Sub

・ツリー全体表示


	【77915】選択セルをコピペ、印刷、コピーしたセル...

［名前なし］ - 16/2/4(木) 22:07 -


	引用なし

	パスワード

こんばんは。
過去ログは拝見しましたが至らないところがあればご指摘ください。

やりたいことを説明しますと、「Aからcの行まで縦に入力された一覧表を一列ずつD1～F1に貼り付け、印刷した後次のセルを選択」です。

selection.resize(,selection.rows.count+2).select
selection.copy
range(D1).select
activesheet.paste
（ここにクイック印刷のマクロ）
selection.offset(1,-3).select

まではなんとか出来たのですが、1列目➡２列目までのあと3,4…と続いてくれません。

お詳しい方いらっしゃいましたらどうぞご教授下さい。
よろしくおねがいします。

・ツリー全体表示


	【77914】Re:複数有る検索結果の横方向への表示方...

laihu - 16/2/4(木) 11:59 -


	引用なし

	パスワード

▼β さん：
早速試してみました。意図通りの結果が出ました。完璧です！
聞いてみるものですね。

自分でも理解できる様、これから勉強していきたいと思います。
今後とも宜しくお願い致します。

>▼laihu さん：
>
>関数は独覚さんにおまかせし、ＶＢＡ処理の一案です。
>
>Sub Test()
>　　Dim dic As Object
>　　Dim c As Range
>　　
>　　Set dic = CreateObject("Scripting.Dictionary")
>　　Application.ScreenUpdating = False
>　　
>　　With Sheets("Sheet1")
>　　　　For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
>　　　　　　If Not dic.exists(c.Value) Then Set dic(c.Value) = CreateObject("Scripting.Dictionary")
>　　　　　　dic(c.Value)(dic(c.Value).Count) = c.Offset(, 1).Value
>　　　　Next
>　　End With
>　　
>　　With Sheets("Sheet2")
>　　　　.Range("A1", .UsedRange).Offset(1, 4).ClearContents
>　　　　For Each c In .Range("D2", .Range("D" & Rows.Count).End(xlUp))
>　　　　　　If dic.exists(c.Value) Then c.Offset(, 1).Resize(, dic(c.Value).Count).Value = dic(c.Value).items
>　　　　Next
>　　　　.Select
>　　End With
>　　
>End Sub

・ツリー全体表示


	【77913】Re:複数有る検索結果の横方向への表示方...

β - 16/2/4(木) 10:14 -


	引用なし

	パスワード

▼laihu さん：

関数は独覚さんにおまかせし、ＶＢＡ処理の一案です。

Sub Test()
　　Dim dic As Object
　　Dim c As Range
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　Application.ScreenUpdating = False
　　
　　With Sheets("Sheet1")
　　　　For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
　　　　　　If Not dic.exists(c.Value) Then Set dic(c.Value) = CreateObject("Scripting.Dictionary")
　　　　　　dic(c.Value)(dic(c.Value).Count) = c.Offset(, 1).Value
　　　　Next
　　End With
　　
　　With Sheets("Sheet2")
　　　　.Range("A1", .UsedRange).Offset(1, 4).ClearContents
　　　　For Each c In .Range("D2", .Range("D" & Rows.Count).End(xlUp))
　　　　　　If dic.exists(c.Value) Then c.Offset(, 1).Resize(, dic(c.Value).Count).Value = dic(c.Value).items
　　　　Next
　　　　.Select
　　End With
　　
End Sub

・ツリー全体表示


	【77911】Re:複数有る検索結果の横方向への表示方...

laihu - 16/2/4(木) 7:55 -


	引用なし

	パスワード

ワークシート関数で現在使用しておりますが、実際は行数が非常に多く、いちいち再計算にかなりの時間がかかります。
ＶＢＡであればそれを最小限に抑えることができるだろうと思っています。

因みに今は下記のような数式をSheet2の各セルに入れています。
もっと簡単な数式があれば是非教えてください。

＜数式＞（下記はSheet2のE2に入る数式です。）
{=IF($D2="","",IF(COUNTIF(Sheet1!$A:$A,$D2)<COLUMN(A1),"",INDEX(Sheet1!$B:$B,SMALL(IF(Sheet1!$A:$A=$D2,ROW($D:$D)),COLUMN(A1)))))}

・ツリー全体表示


	【77910】Re:複数有る検索結果の横方向への表示方...

独覚 - 16/2/3(水) 9:52 -


	引用なし

	パスワード

▼laihu さん：
ワークシート関数で行う方法もありますがマクロのほうがいいでしょうか？

・ツリー全体表示


	【77909】複数有る検索結果の横方向への表示方法に...

laihu - 16/2/3(水) 9:41 -


	引用なし

	パスワード

こんにちは。
VBA初心者で自分なりに何度も試みているのですが
なかなかうまくいかないので教えて頂ければ幸いです。

Sheet1のA列(重複有り)の内、Sheet2のD列（重複無し）と値が一致するものを検索し、sheet1で値が一致した全ての行のB列の値を、順にSheet2の該当する行の、
E,F,G列に横方向に代入していくというものです。

言葉では説明しにくいので、下記のようなイメージでご理解頂けるでしょうか？
-----------------------------------------------------------------------
【マクロ実行前】
-----------------------------------------------------------------------
<Sheet1>

(A) 　B 　　C 　　D　　 E
　イ　あ
　ロ　い
　イ　う
　ニ　え
　イ　お
-----------------------------------------------------------------------
<Sheet2>

A　　B 　　C 　 (D)　　E 　　F　　 G
　　　　　　　　　イ　
　　　　　　　　ロ　
　　　　　　　　　ハ
　　　　　　　　　ニ　
　　　　　　　　　ホ
------------------------------------------------------------------------
【マクロ実行後】
-----------------------------------------------------------------------
<Sheet2>

A　　B　　 C　　(D)　　E 　　F　　 G
　　　　　　　　　イ　　あ　　う　　お
　　　　　　　　ロ　　い
　　　　　　　　　ハ
　　　　　　　　　ニ　　え
　　　　　　　　　ホ
------------------------------------------------------------------------

Sheet1のA列、Sheet2のD列は毎回行数が変化するのでxlUpを使った変数として扱い、sheet2のE、F、G列についてはMAX3列ですので、変数を5to7とし、自分なりに作ってみたのですが、変数と繰り返し処理の指示に不慣れでうまくいきません。

説明不足な部分もあるかと思いますが、教えて頂ければとても助かります。

・ツリー全体表示


	【77908】Re:文字列の一括返還について

独覚 - 16/2/2(火) 13:33 -


	引用なし

	パスワード

>仮に他のサイトで解決したのなら、ここにも必ずその顛末を書いてください。質問しっぱなし、というのはモラルに反します。「解決したからいいや」というのではありません。
に従ってどうやって解決したかの報告をこことエクセルの学校（いまだにほったらかし）
へもお願いいたします。

単にどこそこで解決した、は報告になりませんので。

・ツリー全体表示


	【77907】Re:文字列の一括返還について

タークン

- 16/2/2(火) 12:13 -


	引用なし

	パスワード

おっしゃられる通りです。
このまま、残させていただきます。

ご指導ありがとうございました。

・ツリー全体表示


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

226 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free