Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
283 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【76775】Re:複数のエクセルファイルから条件に一...
質問  M  - 15/3/11(水) 9:59 -
引用なし
パスワード
   ▼β さん：
ありがとうございます。
テスト1のコードを入力したら正常に動作しました。

当初の質問で"特定のデータフォルダに複数のエクセルファイルデータがあり"と書いていましたが、フォルダ内のファイルはCSVファイルでした。

エクセルファイルでは正常に動作したので、
fName = Dir(FolderPath & "*.xls")
の部分を"*.csv"に変更したところ
If IsNumeric(z) Then c.EntireRow.Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
の行に"Rangeメソッドは失敗しました。Worksheetオブジェクト"とのエラーが出ます。
申し訳ありませんが、csvファイルでも同様に判定し、抽出できるようにできないでしょうか。
・ツリー全体表示
【76774】Re:複数のエクセルファイルから条件に一...
発言  β  - 15/3/11(水) 8:37 -
引用なし
パスワード
   ▼M さん：

とりあえず２つほど。

なお、
Const FolderPath As String = "C:\Users\140328\Desktop\新しいフォルダー"
これでは、このコードをMさんのPC以外で実行することができませんので
パスは動的に取得します。
また、サブフォルダからの抽出は不要のようですので、処理的に軽くて効率の良い
DIR関数によるファイル抽出にしました。

Test1は基本形というか、一行ごとにシート関数のMATCHを使ってチェック。
該当のものを、一行ずつ転記。

Test2は、効率を重視し、比較をDictionaryで行い、また、該当行もDictionaryに収めて
最後に一度でシートに書き込むタイプです。

このほかに、オートフィルターやフィルターオプションを使って処理する方法もありますね。

Sub Test1()
　　Dim FolderPath　As String
　　Dim fName As String
　　Dim shT As Worksheet
　　Dim shF As Worksheet
　　Dim z As Variant
　　Dim ckR As Range
　　Dim c As Range
　　Dim done As Boolean
　　
　　Application.ScreenUpdating = False
　　
　　'フォルダパスを動的に取得
　　FolderPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\新しいフォルダー\"
　　'または FolderPath = Environ("USERPROFILE") & "\DeskTOp\新しいフォルダ\"
　　
　　Set shT = ThisWorkbook.Sheets(2)
　　With ThisWorkbook.Sheets(1)
　　　　'指定番号領域
　　　　Set ckR = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　End With
　　'転記シートのクリア
　　shT.UsedRange.ClearContents
　　
　　'フォルダからエクセルブックを抽出
　　fName = Dir(FolderPath & "*.xls")
　　
　　Do While fName <> ""　　'抽出が終われば空白が返る。
　　
　　　　Set shF = Workbooks.Open(FolderPath & fName).Sheets(1)
　　　　'最初のデータブックからタイトル行をコピー
　　　　If Not done Then shF.Rows(1).Copy shT.Range("A1")
　　　　done = True
　　　　
　　　　For Each c In shF.Range("C2", shF.Range("C" & Rows.Count).End(xlUp))
　　　　　　'指定数字かどうか
　　　　　　z = Application.Match(c.Value, ckR, 0)
　　　　　　If IsNumeric(z) Then c.EntireRow.Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　Next
　　　　
　　　　shF.Parent.Close False
　　　　fName = Dir()　 '次のファイルを抽出
　　　　
　　Loop
　　
　　shT.Select
　　
End Sub

Sub Test2()
　　Dim FolderPath　As String
　　Dim fName As String
　　Dim shT As Worksheet
　　Dim shF As Worksheet
　　Dim z As Variant
　　Dim c As Range
　　Dim done As Boolean
　　Dim ck As Object
　　Dim dt As Object
　　Dim cols As Long
　　
　　Application.ScreenUpdating = False
　　
　　'フォルダパスを動的に取得
　　FolderPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\新しいフォルダー\"
　　'または FolderPath = Environ("USERPROFILE") & "\DeskTOp\新しいフォルダ\"
　　
　　Set ck = CreateObject("Scripting.Dictionary")
　　Set dt = CreateObject("Scripting.Dictionary")
　　
　　Set shT = ThisWorkbook.Sheets(2)
　　With ThisWorkbook.Sheets(1)
　　　　'指定番号をDictionaryに格納
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　ck(c.Value) = True
　　　　Next
　　End With
　　'転記シートのクリア
　　shT.UsedRange.ClearContents
　　
　　'フォルダからエクセルブックを抽出
　　fName = Dir(FolderPath & "*.xls")
　　
　　Do While fName <> ""　　'抽出が終われば空白が返る。
　　
　　　　Set shF = Workbooks.Open(FolderPath & fName).Sheets(1)
　　　　'最初のデータブックからタイトル行をコピー
　　　　If Not done Then
　　　　　　With shF.Range("A1").CurrentRegion.Rows(1)
　　　　　　　　dt(dt.Count) = .Value
　　　　　　　　cols = .Columns.Count
　　　　　　　　done = True
　　　　　　End With
　　　　End If
　　　　
　　　　For Each c In shF.Range("C2", shF.Range("C" & Rows.Count).End(xlUp))
　　　　　　'指定数字ならコピー
　　　　　　If ck.exists(c.Value) Then dt(dt.Count) = c.EntireRow.Resize(, cols).Value
　　　　Next
　　　　
　　　　shF.Parent.Close False
　　　　fName = Dir()　 '次のファイルを抽出
　　　　
　　Loop
　　
　　'一括転記
　　shT.Range("A1").Resize(dt.Count, cols).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dt.items))
　　shT.Select
　　
End Sub
・ツリー全体表示
【76773】Re:検索後のHTML解析
発言  banｔ  - 15/3/11(水) 8:34 -
引用なし
パスワード
   コードは変えずにうまくいったりだめだったりするのですね。
うまくいく場合とだめな場合とで法則のようなものはありますか。
うまくいく場合は検索してページ数が取得できて、
では、だめな場合はどうなるのですか。
・ツリー全体表示
【76772】Re:複数のエクセルファイルから条件に一...
発言  β  - 15/3/11(水) 6:54 -
引用なし
パスワード
   ▼M さん：

おはようございます

ちょっと整理させてください

・マクロブックの一番左側のシートのＡ列に数字が列挙されている
　たとえば

　A1 10
　A2 20
　A3 30

・フォルダ内に複数のデータブックがあって、その一番左側のシートの各行のＣ列に
　なにかしら数字がはいっている。それをマクロブック側で指定した数字（例では 10,20,30)
　と比較し、同じであれば、その行をマクロブックの左から２番目のシートに上詰めで転記する。

こういうことじゃないのですか？

現在のコードでは、マクロブック側のシートの 1行目とデータブックのシートの1行目、
2行目と2行目、3行目と3行目、それを比較して、マッチしたら、それをマクロブックの2番目のシートの
その行に転記、たとえば 1行目がマッチしたら1行目に転記。
かつ、どのデータブックに対しても、1行目がマッチしたら1行目に転記ですから上書き。

マッチングも適切ではありませんし、書き込み行も適切ではないですね？

追加で

・フォルダの中のサブフォルダからの抽出は考えなくていいですね？
・フォルダ側のデータブックのシートの１行目はタイトル行ですか？
・ツリー全体表示
【76770】Re:集計について
お礼  ビギナー  - 15/3/10(火) 22:14 -
引用なし
パスワード
   β さん

ご返信有り難うございます。
無事マクロは実行できました。

ただ、以前自分が作ったfor nextを使ったものが動かなかった原因や、
β さんが作って下さったコードも理解できていないところもあり、
そこらへんをハッキリさせていかないと今後似たようなタイプのマクロを作る際に、
活かせないので、そこは勉強していこうと思います。

色々と有り難うございました。
とても勉強になりました。


>▼ビギナー さん：
>
>以下で試してみてください
>
>Sub 数式の埋め込みタイプ3()
>　　
>　　Sheets("Sheet2").Cells.Clear
>　　Sheets("Sheet1").Columns("J").Copy Sheets("Sheet2").Range("A1")
>　　Sheets("Sheet2").Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
>　　
>　　
>　　Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Offset(, 1).Resize(, 4).Formula = _
>　　　　"=SUMIFS(Sheet1!D:D,Sheet1!$J:$J,Sheet2!$A2,Sheet1!$C:$C,""販売"")"
>
>End Sub
・ツリー全体表示
【76769】複数のエクセルファイルから条件に一致す...
質問  M  - 15/3/10(火) 21:23 -
引用なし
パスワード
   特定のデータフォルダに複数のエクセルファイルデータがあり、それを一つのエクセルﾌｧｲﾙに抽出する際に、今開いているエクセルファイルのシート1のA列に80個程度数値があり、その数値とデータファイルのC列が一致した場合のみ、データファイルの一致した行を抽出マクロを検討しています。
　以下のコードで組んでみたのですが、最初の一行しか抽出せずに、一行目に上書きされてしまいます。どのようにしたらよいのでしょうか。
良ければご意見お願いいたします。

Sub Sample()
Const FolderPath As String = "C:\Users\140328\Desktop\新しいフォルダー"
Dim objFSO As Object
Dim objBook As Object
Dim LastRow As Long
Dim i As Integer
Dim STRcsv As Variant
Dim kijun As Variant

Application.ScreenUpdating = False '画面のちらつき制御設定

Set objFSO = CreateObject("Scripting.FileSystemObject") 'FileSystemObjectを変数にセット

For Each objBook In objFSO.GetFolder(FolderPath).Files 'フォルダ内のファイル全て繰り返し処理
　
Workbooks.Open objBook.Path 'ファイルを開く

　LastRow = ActiveWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row '各シートのデータ(最終行+1)の取得
　
　　For i = 1 To 750
　　
　　 If ThisWorkbook.Sheets(1).Cells(i, 1) = ActiveWorkbook.Sheets(1).Cells(i, 3) Then
　　　 ActiveWorkbook.Sheets(1).Rows(i).Copy ThisWorkbook.Sheets(2).Rows(i)
　　 Else
　　　
　　 End If
　
　　Next i
　
　ActiveWorkbook.Close 'コピー後ファイルを閉じる
　
　Next

'オブジェクト変数解放
Set objFSO = Nothing

'画面のちらつき制御解除
Application.ScreenUpdating = True

End Sub
・ツリー全体表示
【76768】Re:検索後のHTML解析
質問  Satsuki  - 15/3/10(火) 20:09 -
引用なし
パスワード
   ▼banｔ 様
ご回答ありがとうございます。

>mougでの質問では
>　　PageNum = getMaxPage(objIE)　
>この部分で検索前のobjIEのままということでしたが、
>検索後のobjIEを取得できている場合もあるということですか。
mougの方も見て頂いていたのですね。ありがとうございます。

以前からお世話になっているこちらのサイトで質問しようとしたところ
禁則文字とのエラーが出て投稿できなかったので
(前回はｈｔｔｐから始まるＵＲＬが入っていたために
エラーが出たと気づきませんでした。)、
新たに探してmougのサイトで質問したのですが、
そちらで教えて頂いたところ、
PageNum = getMaxPage(objDoc)
というふうにdocumentを渡しているので、上手く行かないのだと気づき、
再度調べて、今度はobjIEを渡せば上手く行くかと思い書き直しました。
・ツリー全体表示
【76767】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/3/10(火) 18:13 -
引用なし
パスワード
   ▼あや さん：

以下は、Sheet2の値が部分一致でSheet3にあるかどうかをみています。
不安ですが・・・
試してみてください。

Sub Test3()
　　Dim reg As Object
　　Dim dic As Object
　　Dim Dup As Object
　　Dim i As Long
　　Dim v As Variant
　　Dim c As Range
　　Dim str3 As String
　　
　　Set reg = CreateObject("VBScript.RegExp")　 '文字列比較エンジン
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　Set Dup = CreateObject("Scripting.Dictionary")
　　
　　'Sheet3の名前を取り出してDicに格納
　　With Sheets("Sheet3")
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　dic(c.Value) = True
　　　　Next
　　End With
　　
　　'Sheet3の各文字列を vbtab で挟み連結
　　str3 = vbTab & Join(dic.keys, vbTab) & vbTab
　　
　　'Sheet2の各文字列をSheet3の連結文字列とワイルドカード比較
　　With Sheets("Sheet2")
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　'ワイルドカード比較パターン
　　　　　　reg.Pattern = vbTab & ".*" & c.Value & ".*?" & vbTab
　　　　　　'Sheet3側にあればSheet2のB列の値を格納
　　　　　　If reg.Test(str3) Then Dup(c.Offset(, 1).Value) = True　　　　　　　　　　'
　　　　Next
　　End With
　
　　If Dup.Count > 0 Then
　　　　MsgBox "以下の地域に重複がありました" & vbLf & Join(Dup.keys, vbLf)
　　Else
　　　　MsgBox "重複はありませんでした"
　　End If
　
End Sub
・ツリー全体表示
【76766】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/3/10(火) 16:17 -
引用なし
パスワード
   ▼あや さん：

おっとぉ！
難易度がぐ〜んとアップしましたね。
Dictionaryでの（直接）比較は、ワイルドカードがつかえませんので
すべてをなめて、Like 判定をするという手もありますが、ちょっと別の方法を考えてみます。
（老化進行防止のための、いいトレーニングになります）

ところで、部分一致ですが

Sheet2の語句がSheet3の語句と部分一致
Sheet3の語句がSheet2の語句と部分一致

どちらでしょうか？

なお、重複表示をB列にすることは問題ありません。


>▼β さん：
>なるほど・・・
>シート3で重複しているものも全て表示させようとしたため
>dl.Add c.Valueという書き方をしているのですね。
>また結果表示も同じものも表示させるために、重複を見つけるたびにv(i)に格納していくのですね。
>有難うございます。
>
>またまた質問で申し訳ないのですが・・・
>1.今回の処理はセル同士を見比べているので、セルの値が完全一致のものを表示させていると思うのですが、これを部分一致にさせることというのは可能なのでしょうか(lookat:=xlPartのような・・・)
>2.見比べはシート2とシート3のA列で行うのですが、結果表示をさせるときにシート2のA列の結果ではなく、シート2のB列の結果を表示させる、ということは可能でしょうか。
>(B列に地区名が入っていて、知りたいのは重複した名前の人の地区というような・・・
>dl.Offset(0, 1)を使うとうまくいかなかったもので・・・)
>
>何度も申し訳ありません。
>
>>▼あや さん：
>>
>>まず、このコードは２つの入れ物を使っています。
>> １つが Dictionary と呼ばれるもの。もう１つがArrayListと呼ばれるものです。
>>いずれもＶＢＡの持ち物ではなく 外部（.Net等）の機能なので、CreateObject で呼び出して使用。
>>
>>Dictionary は同じキーを格納した時に上書きされる特徴をもっていて、コードでは
>>Sheet2の名前を格納するのに使っています。山田が何件あろうと１件の山田になります。
>>
>>ArrayListは、キー／データという概念はないのですが同じ値を別のものとして格納可能です。
>>コードでは、重複のあったものを格納するのに使っています。Sheet3 に山田が３件あれば３件格納されます。
>>また、ArrayListは格納されたものを昇順、降順に並び替える機能もあります。
>>エラーメッセージで
>>山田
>> 佐藤
>> 山田
>> 佐藤
>>とだすより
>>山田
>> 山田
>> 佐藤
>> 佐藤
>>とだすほうがわかりやすいので、この昇順並び替え機能を使っています。（これが dl.Sort です）
>>
>>Dictionaryには、Existsメソッドがあり、ある値が、Dictionaryのキーとして格納されているかどうかの
>>判定ができます。それが　dic.exists(c.Value)　で、このメソッドが返す結果が True なら　
>> 重複しているということになりますので、それを dl.Add c.Value　でArrayList に登録しています。
>>
>>ArrayListに格納した内容は、ＶＢＡからは一挙に取り出せないので、ArrayListと同じ大きさの
>>ReDim v(0 To dl.Count - 1)　で１次元配列をつくり、その配列に、ArrayListからインデックスを与えながら
>>v(i) = dl(i)　で、データを取り出しておさめています。
>> （ArrayListのインデックスは 0 から始まっています）
>>
>>さて、重複側を、あえてその件数だけすべて表示するという要望でしたのでArrayListを使いましたが
>>集約して１件にして表示するなら、重複情報も ArrayListではなくDictionary に格納して重複をなくす
>> ことができます。
>>
>> 以下でお試しください。
>>
>>Sub Test2()
>>　　Dim dic As Object
>>　　Dim dl As Object
>>　　Dim i As Long
>>　　Dim v As Variant
>>　　Dim c As Range
>>　
>> 　　Set dic = CreateObject("Scripting.Dictionary")
>>　　Set dl = CreateObject("Scripting.Dictionary")
>>　
>> 　　 With Sheets("Sheet2")
>>　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
>>　　　　　　dic(c.Value) = True
>>　　　　Next
>>　　End With
>>　
>> 　　 With Sheets("Sheet3")
>>　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
>>　　　　　　If dic.exists(c.Value) Then dl(c.Value) = True
>>　　　　Next
>>　　End With
>>　
>> 　　If dl.Count > 0 Then
>>　　　　MsgBox "以下の重複がありました" & vbLf & Join(dl.keys, vbLf)
>>　　Else
>>　　　　MsgBox "重複はありませんでした"
>>　　End If
>>　
>>End Sub
・ツリー全体表示
【76765】Re:シート1とシート2の内容で一致するも...
質問  あや  - 15/3/10(火) 14:14 -
引用なし
パスワード
   ▼β さん：
なるほど・・・
シート3で重複しているものも全て表示させようとしたため
dl.Add c.Valueという書き方をしているのですね。
また結果表示も同じものも表示させるために、重複を見つけるたびにv(i)に格納していくのですね。
有難うございます。

またまた質問で申し訳ないのですが・・・
1.今回の処理はセル同士を見比べているので、セルの値が完全一致のものを表示させていると思うのですが、これを部分一致にさせることというのは可能なのでしょうか(lookat:=xlPartのような・・・)
2.見比べはシート2とシート3のA列で行うのですが、結果表示をさせるときにシート2のA列の結果ではなく、シート2のB列の結果を表示させる、ということは可能でしょうか。
(B列に地区名が入っていて、知りたいのは重複した名前の人の地区というような・・・
dl.Offset(0, 1)を使うとうまくいかなかったもので・・・)

何度も申し訳ありません。

>▼あや さん：
>
>まず、このコードは２つの入れ物を使っています。
> １つが Dictionary と呼ばれるもの。もう１つがArrayListと呼ばれるものです。
>いずれもＶＢＡの持ち物ではなく 外部（.Net等）の機能なので、CreateObject で呼び出して使用。
>
>Dictionary は同じキーを格納した時に上書きされる特徴をもっていて、コードでは
>Sheet2の名前を格納するのに使っています。山田が何件あろうと１件の山田になります。
>
>ArrayListは、キー／データという概念はないのですが同じ値を別のものとして格納可能です。
>コードでは、重複のあったものを格納するのに使っています。Sheet3 に山田が３件あれば３件格納されます。
>また、ArrayListは格納されたものを昇順、降順に並び替える機能もあります。
>エラーメッセージで
>山田
> 佐藤
> 山田
> 佐藤
>とだすより
>山田
> 山田
> 佐藤
> 佐藤
>とだすほうがわかりやすいので、この昇順並び替え機能を使っています。（これが dl.Sort です）
>
>Dictionaryには、Existsメソッドがあり、ある値が、Dictionaryのキーとして格納されているかどうかの
>判定ができます。それが　dic.exists(c.Value)　で、このメソッドが返す結果が True なら　
> 重複しているということになりますので、それを dl.Add c.Value　でArrayList に登録しています。
>
>ArrayListに格納した内容は、ＶＢＡからは一挙に取り出せないので、ArrayListと同じ大きさの
>ReDim v(0 To dl.Count - 1)　で１次元配列をつくり、その配列に、ArrayListからインデックスを与えながら
>v(i) = dl(i)　で、データを取り出しておさめています。
> （ArrayListのインデックスは 0 から始まっています）
>
>さて、重複側を、あえてその件数だけすべて表示するという要望でしたのでArrayListを使いましたが
>集約して１件にして表示するなら、重複情報も ArrayListではなくDictionary に格納して重複をなくす
> ことができます。
>
> 以下でお試しください。
>
>Sub Test2()
>　　Dim dic As Object
>　　Dim dl As Object
>　　Dim i As Long
>　　Dim v As Variant
>　　Dim c As Range
>　
> 　　Set dic = CreateObject("Scripting.Dictionary")
>　　Set dl = CreateObject("Scripting.Dictionary")
>　
> 　　 With Sheets("Sheet2")
>　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
>　　　　　　dic(c.Value) = True
>　　　　Next
>　　End With
>　
> 　　 With Sheets("Sheet3")
>　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
>　　　　　　If dic.exists(c.Value) Then dl(c.Value) = True
>　　　　Next
>　　End With
>　
> 　　If dl.Count > 0 Then
>　　　　MsgBox "以下の重複がありました" & vbLf & Join(dl.keys, vbLf)
>　　Else
>　　　　MsgBox "重複はありませんでした"
>　　End If
>　
>End Sub
・ツリー全体表示
【76764】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/3/10(火) 13:20 -
引用なし
パスワード
   ▼あや さん：

まず、このコードは２つの入れ物を使っています。
１つが Dictionary と呼ばれるもの。もう１つがArrayListと呼ばれるものです。
いずれもＶＢＡの持ち物ではなく 外部（.Net等）の機能なので、CreateObject で呼び出して使用。

Dictionary は同じキーを格納した時に上書きされる特徴をもっていて、コードでは
Sheet2の名前を格納するのに使っています。山田が何件あろうと１件の山田になります。

ArrayListは、キー／データという概念はないのですが同じ値を別のものとして格納可能です。
コードでは、重複のあったものを格納するのに使っています。Sheet3 に山田が３件あれば３件格納されます。
また、ArrayListは格納されたものを昇順、降順に並び替える機能もあります。
エラーメッセージで
山田
佐藤
山田
佐藤
とだすより
山田
山田
佐藤
佐藤
とだすほうがわかりやすいので、この昇順並び替え機能を使っています。（これが dl.Sort です）

Dictionaryには、Existsメソッドがあり、ある値が、Dictionaryのキーとして格納されているかどうかの
判定ができます。それが　dic.exists(c.Value)　で、このメソッドが返す結果が True なら　
重複しているということになりますので、それを dl.Add c.Value　でArrayList に登録しています。

ArrayListに格納した内容は、ＶＢＡからは一挙に取り出せないので、ArrayListと同じ大きさの
ReDim v(0 To dl.Count - 1)　で１次元配列をつくり、その配列に、ArrayListからインデックスを与えながら
v(i) = dl(i)　で、データを取り出しておさめています。
（ArrayListのインデックスは 0 から始まっています）

さて、重複側を、あえてその件数だけすべて表示するという要望でしたのでArrayListを使いましたが
集約して１件にして表示するなら、重複情報も ArrayListではなくDictionary に格納して重複をなくす
ことができます。

以下でお試しください。

Sub Test2()
　　Dim dic As Object
　　Dim dl As Object
　　Dim i As Long
　　Dim v As Variant
　　Dim c As Range
　
　　Set dic = CreateObject("Scripting.Dictionary")
　　Set dl = CreateObject("Scripting.Dictionary")
　
　　 With Sheets("Sheet2")
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　dic(c.Value) = True
　　　　Next
　　End With
　
　　 With Sheets("Sheet3")
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　If dic.exists(c.Value) Then dl(c.Value) = True
　　　　Next
　　End With
　
　　If dl.Count > 0 Then
　　　　MsgBox "以下の重複がありました" & vbLf & Join(dl.keys, vbLf)
　　Else
　　　　MsgBox "重複はありませんでした"
　　End If
　
End Sub
・ツリー全体表示
【76763】Re:検索後のHTML解析
発言  banｔ  - 15/3/10(火) 11:29 -
引用なし
パスワード
   mougでの質問では
　　PageNum = getMaxPage(objIE)　
この部分で検索前のobjIEのままということでしたが、
検索後のobjIEを取得できている場合もあるということですか。
・ツリー全体表示
【76762】Re:シート1とシート2の内容で一致するも...
お礼  あや  - 15/3/10(火) 11:24 -
引用なし
パスワード
   ▼マナ さん：
回答ありがとうございます。
マクロを使う方法なのですね。
試してみます。


>マクロの記録で作成する例です。
>最後のメッセージボックスだけはちょっと無理でしたので
>シート１のA列にコピペにしました。
>
>１．Sheet3のA1に行挿入
>２．Sheet3のA1に「大阪」と入力
>３．Sheet3のB2に式入力　=COUNTIF(Sheet2!A:A,A2)
>４．Sheet3のB列を下方向にフィルコピー
>５．Sheet3でオートフィルター
>６．Sheet3のB列で数値フィルター　0と等しくない
>７．Sheet3のA列抽出行をSheet1のA列にコピペ
>８．Sheet3のオートフィルター解除
>９．Sheet3のB列削除
>１０．Sheet3の１行目を選択し行削除
・ツリー全体表示
【76761】Re:シート1とシート2の内容で一致するも...
質問  あや  - 15/3/10(火) 11:20 -
引用なし
パスワード
   ▼β さん：
2パターンの情報提供、またコードまで書いていただき有難うございます。
最初の方が簡単そうだったので作成してみましたが、シート1はきれいなままにしておきたいので、2つ目の方法で進めていきたいと思います。
部分部分分からないところがあるので教えていただきたいのですがよろしいでしょうか？
1.>　　　　　　If dic.exists(c.Value) Then dl.Add c.Value
　この行のThen dl.Add c.Valueはどういう処理を行っているのでしょうか
2.>　　　　dl.Sort
　>　　　　ReDim v(0 To dl.Count - 1)
　>　　　　For i = 0 To dl.Count - 1
　>　　　　　　v(i) = dl(i)
　ここでどのような処理を行っているのでしょうか・・・
　ReDimが重複しているものも表示するものというのはわかったのですが・・・


また追加で質問があります。
同じ名前を発見した場合は最初に発見した方だけ表示するようにするには
>　　　　ReDim v(0 To dl.Count - 1)
を削除するほかに
>　　If dl.Count > 0 Then
>　　　　dl.Sort
>　　　　ReDim v(0 To dl.Count - 1)
>　　　　For i = 0 To dl.Count - 1
>　　　　　　v(i) = dl(i)
ここをどう変更すればよいのでしょうか・・・
”型が一致しません”や”オブジェクトが無効です”などのエラーが出てきてしまいます・・・
どういう処理をしているか解れば解決するのかな、とは思っているのですが・・・

質問ばかりで申し訳ありません。
回答宜しくお願い致します。


>▼あや さん：
>
>こんなコードもあります。
>シンプルですが、わかりにくいかも。
>
>Sub Test()
>　　Dim dic As Object
>　　Dim dl As Object
>　　Dim i As Long
>　　Dim v As Variant
>　　Dim c As Range
>　　
>　　Set dic = CreateObject("Scripting.Dictionary")
>　　Set dl = CreateObject("System.Collections.ArrayList")
>　　
>　　With Sheets("Sheet2")
>　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
>　　　　　　dic(c.Value) = True
>　　　　Next
>　　End With
>　　
>　　With Sheets("Sheet3")
>　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
>　　　　　　If dic.exists(c.Value) Then dl.Add c.Value
>　　　　Next
>　　End With
>　　
>　　If dl.Count > 0 Then
>　　　　dl.Sort
>　　　　ReDim v(0 To dl.Count - 1)
>　　　　For i = 0 To dl.Count - 1
>　　　　　　v(i) = dl(i)
>　　　　Next
>　　　　MsgBox "以下の重複がありました" & vbLf & Join(v, vbLf)
>　　Else
>　　　　MsgBox "重複はありませんでした"
>　　End If
>　　
>End Sub
・ツリー全体表示
【76760】Re:集計について
発言  CatHand  - 15/3/10(火) 10:06 -
引用なし
パスワード
   ▼ビギナー さん：

えーっと、この要件だとエクセルの標準機能のピボットテーブルの
方が柔軟に対応できそうですがダメなんですかねぇ？

＊以下個人的なおもいです。
エクセルには便利で強力な標準機能が色々と実装されています。
それらで補えないところがVBAの出番だと思います。
・ツリー全体表示
【76759】Re:集計について
発言  β  - 15/3/10(火) 8:52 -
引用なし
パスワード
   ▼ビギナー さん：

以下で試してみてください

Sub 数式の埋め込みタイプ3()
　　
　　Sheets("Sheet2").Cells.Clear
　　Sheets("Sheet1").Columns("J").Copy Sheets("Sheet2").Range("A1")
　　Sheets("Sheet2").Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
　　
　　
　　Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Offset(, 1).Resize(, 4).Formula = _
　　　　"=SUMIFS(Sheet1!D:D,Sheet1!$J:$J,Sheet2!$A2,Sheet1!$C:$C,""販売"")"

End Sub
・ツリー全体表示
【76758】Re:集計について
発言  β  - 15/3/9(月) 22:53 -
引用なし
パスワード
   ▼ビギナー さん：

了解です。
今日は、年寄りとしては、おねむなので、回答は明日まで待ってください。
・ツリー全体表示
【76757】Re:集計について
発言  ビギナー  - 15/3/9(月) 22:28 -
引用なし
パスワード
   β 様

別の列から抜き出した数量同士は集約しません。
sheet1のD列から抜き出した数量は、sheet2のB列に、E列から抜き出したものはC列に、という形でずらして入れていきたいと考えております。


▼β さん：
>▼ビギナー さん：
>
>こんばんは
>
>新しく"販売"を抜き出して集計するＤ列〜Ｈ列の集計結果は
>それぞれ、Sheet2のどこにセットするのですか？
>あるいは、４列の集計をさらに集約してSheet2の、どこかの列に１本でセットするのですか？
・ツリー全体表示
【76756】Re:集計について
発言  β  - 15/3/9(月) 22:11 -
引用なし
パスワード
   ▼ビギナー さん：

こんばんは

新しく"販売"を抜き出して集計するＤ列〜Ｈ列の集計結果は
それぞれ、Sheet2のどこにセットするのですか？
あるいは、４列の集計をさらに集約してSheet2の、どこかの列に１本でセットするのですか？
・ツリー全体表示
【76755】Re:集計について
質問  ビギナー  - 15/3/9(月) 21:22 -
引用なし
パスワード
   β 様

先日参考としてコードをご提示して下さり、
有り難うございました。

そのマクロを修正した場合で更に質問がございます。
質問、質問ばかりで申し訳ありません。

新たに実行したい点は下記です。
・Sheet1のD列の数値を集計しておりましたが、E列、F列も同様に集計し(e,f列にもそれぞれ数量が入っている)、Sheet２に入れていきたいと考えました。
そのため、for next で繰り返し処理をしようと考え、下記のようなコードを追加したのですが、
動かない状況です。


dim D as integer
QP = A2 　' sheet2 の集計結果を記載する列です。
For D = 4 To 8 '　集計をするsheet1の列を表しています。４列目から８列目を集計予定。
　　
　　Sheets("Sheet1").Columns("J").Copy Sheets("Sheet2").Range("A1")
　　Sheets("Sheet2").Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
　　Sheets("Sheet2").Range("QP", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Offset(, 1).Formula = _
　　　　"=SUMIFS(Sheet1!D:D,Sheet1!J:J,Sheet2!QP,Sheet1!C:C,""販売"")"
　　　　
　　Range("QP") = Range("QP").Offset(0, 1)
　　
　　Next D

※同じコード内での質問なので、
追加で質問させて頂きましたが、新規として投稿するべきでしたらすぐに修正致します。

何度も質問申し訳ございませんが、よろしくお願い致します。

>▼β さん：
>>▼ビギナー さん：
>>
>>参考にする場合、こちらのコードのほうが比較しやすいですね。
>>
>>Sub 数式の埋め込みタイプ2()
>>　　
>>　　Sheets("Sheet2").Cells.Clear
>>　　Sheets("Sheet1").Columns("J").Copy Sheets("Sheet2").Range("A1")
>>　　Sheets("Sheet2").Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
>>　　Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Offset(, 1).Formula = _
>>　　　　"=SUMIFS(Sheet1!D:D,Sheet1!J:J,Sheet2!A2,Sheet1!C:C,""子供"")"
>>
>>End Sub
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
283 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free