[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルの文字列を比較し転記』（しん）
いつも勉強させて頂いています。長々とパターンを説明します。
工数の積算に使いたいのです。よろしくお願いします。
①A1に山 B1に本 C1に10 と入力すると
A B C D E F
1 山 本 10
2
②D1に山 E1に本 F1に10 と入力される
A B C D E F
1 山 本 10 山 本 10
2
③A2に川 B2に田 C2に10 と入力すると
A B C D E F
1 山 本 10 山 本 10
2 川 田 10
④D2に川 E2に田 F2に10 と入力される
A B C D E F
1 山 本 10 山 本 10
2 川 田 10 川 田 10
⑤A3に山 B3に本 C3に10 と入力すると
A B C D E F
1 山 本 10 山 本 10
2 川 田 10 川 田 10
3 山 本 10
⑥F1の10に加算され20になる
A B C D E F
1 山 本 10 山 本 20
2 川 田 10 川 田 10
3 山 本 10
⑤A4に川 B4に本 C4に10 と入力すると
A B C D E F
1 山 本 10 山 本 20
2 川 田 10 川 田 10
3 山 本 10 川 本 10
4 川 本 10
⑥D3に川 B3に本 C4に10 と入力される
A B C D E F
1 山 本 10 山 本 20
2 川 田 10 川 田 10
3 山 本 10 川 本 10
4 川 本 10
：
A列には任意の文字列、B列も任意の文字列、C列は10固定です。
以上こういうパターンです。
よろしくお願い致します。
こんにちは。かみちゃん です。
あまり名案は思い浮かばないのですが、
> 工数の積算に使いたい
私なら、VBAで処理してしまいますが、その選択肢はあるのでしょうか？ 作業列を使って数式か、もしくは、SUMIF関数、SUMPRODUCT関数でできるかもしれません。
ちなみに、Excelのバージョンは、何ですか？
(かみちゃん) 2009-04-24 0:28
おはようございます。 説明不足ですみません。VBAでする予定でした。 それとExcelは2003のSP3です。 よろしくお願いします。 (しん)
かみちゃんさんの書き込みが無い様ですので 少し確認させて下さい。 （かみちゃんさんからの書き込みが有った場合 無視して下さい。）
１． ご提示のサンプルでは、「山本」「川田」の様に 二つで一セットの様な印象を受けますが実際もそうですか？ 或いは、前後が入れ替わった場合は 違うものとして扱って良いのでしょうか？
２． マクロで処理をするなら、「入力が全て済んだ後に一回実行」 と言う形をとるのが良さそうに思いますが その辺りはどの様にお考えでしょうか？
３． ＞VBAでする予定でした。 朧気ながらでも、構想が有る場合は どの様に処理を進めようと思ったのか 書いてみて下さい。
４． ご提示のサンプルは、1行目からデータが始まっています。 実際のレイアウトもその様に成っているのでしょうか？ 後から 「実際はこうなっていて、どう変更すれば良いか分からない」 なんて事に成るのなら、今の内に 実際のレイアウトを 教えて下さい。 勿論、問題なく処理できるのであれば不要です。
以下、投稿時に気にしてもらいたい点として 例えば、 A1セルに「部署」B1セルに「氏名」C1セルに「個数」と書いてあり 2行目からデータが有れば、（１）の様な事を考える必要性は 無いと判断して良いと思います。
実際も見出しが有る場合は、その性質を想像しやすいような見出し項目を 無い場合は、注釈としてどの様な性質を持ったデータなのか 一緒に書いておいて頂けるのが良いと思います。
(HANA)
こんにちは。かみちゃん です。
> かみちゃんさんの書き込みが無い様ですので
すみません。名案がパッと思い浮かばないのと、考えるためのまとまった時間がないので、 時間がかかるかもしれません。 案をお持ちの方がいらっしゃるなら、そちらにお任せしたいと思っています。
(かみちゃん) 2009-04-25 11:11
シートモジュールへ Const myHeadingRow As Long = 1 列見出しの行は 1 を修正、無い場合は 0
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a, i As Long, b(), n As Long, z As String
Const myHeadingRow As Long = 1
If Intersect(Target, Range("a:c")) Is Nothing Then Exit Sub
If Target.Row < = myHeadingRow Then Exit Sub
If Application.CountA(Target.EntireRow.Range("a1:c1")) <> 3 Then Exit Sub
Application.EnableEvents = False
a = Range("a" & myHeadingRow + 1, Range("a" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
z = Join(Array(a(i, 1), a(i, 2)), ";")
If Not .exists(z) Then
n = n + 1 : .item(z) = n
b(n, 1) = a(i, 1) : b(n, 2) = a(i, 2)
End If
b(.item(z), 3) = b(.item(z), 3) + a(i, 3)
Next
End With
Range("d" & myHeadingRow + 1).Resize(n,3).Value = b '<- ここ修正 13:40
Application.EnableEvents = True
End Sub
(seiya)
修正:11:54
いろいろな方にお世話になり大変ありがたいと思っております。 申し訳ありませんがまだコードを実行していません(><) HANAさんの回答だけ先に
1.はい。二つで１セットです。詳しくお話しすると、A列には任意の文字列が入り、 B列には文字列の10or20が入ります。C列には数字の20が入ります。
2.はいその通りで入力後にボタンクリックイベントにしようと思っていました。
3、4.自分はまだまだ勉強中で、人様のVBAのコードをシートに合わせて アレンジするくらいしかできません・・。見出しはありません。
お手数をおかけしますが、よろしくお願いします。 (しん）
＞C列は10固定です。 と言うお話だったと思いますが、20に変わったのですかね？
いずれにしても、C列は入力されている数値を加算していきます。
どこかで見たようなコードですが。（笑）
'------
Sub sin()
Dim xi As Long
Dim kti As String
Dim tbl, x, dic
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
tbl = Range("A1", Range("C" & Rows.Count).End(xlUp)).Value
ReDim x(1 To UBound(tbl, 1), 1 To 3)
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = tbl(i, 3)
Else
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
End If
Next
Range("D:F").ClearContents
If xi > 0 Then Range("D1").Resize(xi, 3).Value = x
Set dic = Nothing
MsgBox "処理が終わりました。"
End Sub
'------
(HANA)
書き忘れが有ったので、追記です。
＞B列には文字列の10or20が入ります。 と言う事ですので、書き出し先のE列のセルの書式設定は 事前に「文字列」にしておいて下さい。
標準のままで実行すると、E列の値は 数値になって仕舞いますので、気をつけて下さい。
(HANA)
なんか、そのまんまっていうのも芸がないような...
Sub test()
Dim a, w(), i As Long, z As String
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 3).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
z = Join$(Array(a(i, 1), a(i, 2)), ";")
If Not .exists(z) Then .item(z) = VBA.Array(a(i, 1), a(i, 2), 0)
w = .item(z)
w(2) = w(2) + 1
.item(z) = w
Next
Range("d:f").ClearContents
Range("d1").Resize(.count, 3).Value = _
Application.Transpose(Application.Transpose(.items))
End With
End Sub
(seiya)
HANAさん、seiyaさん お返事遅れて大変申し訳ありませんでした。。 早速試してみてお二人とも満足にいくものだったのですが これを自分用に変更しようとしたんですが、理解できてないためエラーになってしまいました。
A1～C1にあたるのがC3～E3でC50～E50までとI3～K3でI50～E50まであります。 C50～E50の次がI3～K3からになります。
D1～F1にあたるのがM3～O3です。
自分が変更して試したところは
Sub sin()
Dim xi As Long
Dim kti As String
Dim tbl, x, dic
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
tbl = Range("C3", Range("E" & Rows.Count).End(xlUp)).Value
~~ ~~
ReDim x(1 To UBound(tbl, 1), 1 To 3)
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = tbl(i, 3)
Else
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
End If
Next
Range("M:O).ClearContents
~~~~
If xi > 0 Then Range("M3").Resize(xi, 3).Value = x
~~~
Set dic = Nothing
MsgBox "処理が終わりました。"
End Sub
どこをどうすれば良いのでしょうか？ 勉強したいと思います。 よろしくお願いします。 (しん)
こんにちは。かみちゃん です。
横から失礼します。
> エラーになってしまいました
コードのどの行で、どのようなエラーメッセージが出ているのでしょうか？
Range("M:O).ClearContents
の部分ですと、"M:O" としないといけないと思います。
> A1～C1にあたるのがC3～E3でC50～E50までとI3～K3でI50～E50まであります。 > C50～E50の次がI3～K3からになります。 > > D1～F1にあたるのがM3～O3です。
I50～E50とはどういうセル範囲ですか？ もしかして、C3:E50とI3:K50のセル範囲を M3:O3以下に最大96行（48行×2）出力させたいということでしょうか？
それであれば、以下のようにしないといけないのではないでしょうか？ もっとスマートな方法があるかもしれませんが・・・
Sub sin2() Dim xi As Long Dim kti As String Dim tbl, x, dic Dim i As Long
Dim rngTbl(1) As Range Dim j As Integer
Const clngRow As Long = 48 'C3:E50,I3:K50 は48行
Set rngTbl(0) = Range("C3").Resize(clngRow, 3)
Set rngTbl(1) = Range("I3").Resize(clngRow, 3)
ReDim x(1 To clngRow * 2, 1 To 3)
Set dic = CreateObject("Scripting.Dictionary")
For j = 0 To 1
tbl = rngTbl(j).Value
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = tbl(i, 3)
Else
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
End If
Next
Next
Range("M:O").ClearContents
If xi > 0 Then Range("M3").Resize(xi, 3).Value = x
Set dic = Nothing MsgBox "処理が終わりました。" End Sub
(かみちゃん) 2009-04-27 23:38
だから最初に ＞後から ＞ 「実際はこうなっていて、どう変更すれば良いか分からない」 ＞なんて事に成るのなら、今の内に 実際のレイアウトを ＞教えて下さい。 と書いておいたのですけどね。
常識的に考えて、決め打ちしても良さそうな所も有りますが 取りあえず、こんな感じにしてみました。
'------
Sub sin3()
Dim xi As Long
Dim kti As String
Dim tbl, x, dic, ca
Dim i As Long, ii As Long
ca = Array("C", "I") '<--ここに先頭の列番号を記入
Set dic = CreateObject("Scripting.Dictionary")
ReDim x(1 To 3, 1 To 3)
For ii = 0 To UBound(ca)
If Range(ca(ii) & Rows.Count).End(xlUp).Row - 2 > 0 Then
tbl = Range(ca(ii) & "3").Resize(Range(ca(ii) & Rows.Count).End(xlUp).Row - 2, 3).Value
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
If UBound(x, 1) < xi Then
ReDim Preserve x(1 To UBound(x, 1) + UBound(tbl, 1), 1 To 3)
End If
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = tbl(i, 3)
Else
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
End If
Next
End If
Next
Range("M3").Resize(Range("M3").End(xlDown).Row - 2, 3).ClearContents
If xi > 0 Then Range("M3").Resize(xi, 3).Value = x
Set dic = Nothing
MsgBox "処理が終わりました。"
End Sub
'------
(HANA)
HANAさん、かみちゃんさん 夜分遅くありがとうございました。 実行してみてうまくいったのですが、まだ伝えていないレイアウトがありましてうまく行きませんでした。本当にすみません・・。 http://firestorage.jp/download/bf3193401c163aec5911a5c79849c28933304e88 こちらにUPしました。F3とL3もE3とK3同様積算したかったんです。 一度見てみていただけないでしょうか？ よろしくお願いします。
---追記--- F3とL3はP3に対応しています。 (しん)
こんにちは。かみちゃん です。
To,HANAさん、しんさん
>> 取りあえず、こんな感じにしてみました。 > > 実行してみてうまくいった
HANAさんご提示のコードなのですが、 ReDim x(1 To 3, 1 To 3) としている後に、For ～ Next ループ内で ReDim Preserve x(1 To UBound(x, 1) + UBound(tbl, 1), 1 To 3) という処理をしていますが、このコードで「インデックスが有効範囲にありません」というエラーになりませんか？
ReDimステートメントのヘルプによると、 >> キーワード Preserve を指定した場合、変更できるのは、動的配列の最後の次元のサイズに限られます。 とあると思います。
HANAさんのことですから、問題ないのでしたら、なぜ問題ないのか、教えていただければと思います。
ただ、こちらで試したところ、そういうエラーが出ます。 しんさんがUPされたファイルは、C列とD列およびI列とJ列の組み合わせが、「あ_1」「あ_10」「_」の 3種類しかないので、しんさんが試されたときは、うまくいっていると思いますが、仮にC列が「あ」D列が「2」という別 の組み合わせを追加して試してみてください。
> F3とL3もE3とK3同様積算したかった
UPされたファイルを恐る恐る拝見しましたが、シートレイアウトは、よくわかりました。 ただ、E列、K列に数値以外の値が入っているようですが、これは、どのように集計するのですか？ マクロ実行前のシートレイアウトは、よくわかりましたが、実行後どうなってほしいのか、期待している結果を 手作業で作って示すことはできませんか？
(かみちゃん) 2009-04-28 7:32
こんにちは。かみちゃん です。
>> F3とL3もE3とK3同様積算したかった > > UPされたファイルを恐る恐る拝見しましたが、シートレイアウトは、よくわかりました。 > ただ、E列、K列に数値以外の値が入っているようですが、これは、どのように集計するのですか？ > マクロ実行前のシートレイアウトは、よくわかりましたが、実行後どうなってほしいのか、期待している結果を > 手作業で作って示すことはできませんか？
これの返答を待ってからにしたほうがいいのですが、 とりあえず、F列もL列も積算したいのであれば、以下の★の行を追加修正することでできると思います。
Sub sin4() Dim xi As Long Dim kti As String Dim tbl, x, dic Dim i As Long
Dim rngTbl(1) As Range Dim j As Integer
Const clngRow As Long = 48 'C3:E50,I3:K50 は48行
Set rngTbl(0) = Range("C3").Resize(clngRow, 4) '★
Set rngTbl(1) = Range("I3").Resize(clngRow, 4) '★
ReDim x(1 To clngRow * 2, 1 To 4) '★
Set dic = CreateObject("Scripting.Dictionary")
For j = 0 To 1
tbl = rngTbl(j).Value
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = tbl(i, 3)
x(xi, 4) = tbl(i, 4) '★
Else
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
x(dic(kti), 4) = x(dic(kti), 4) + tbl(i, 4) '★
End If
Next
Next
Range("M:O").ClearContents
If xi > 0 Then Range("M3").Resize(xi, 4).Value = x '★
Set dic = Nothing MsgBox "処理が終わりました" End Sub
C列とD列の組み合わせ、I列とJ列の組み合わせが同一の場合で、E列とK列、F列とL列に、文字と数値が混在していると
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
x(dic(kti), 4) = x(dic(kti), 4) + tbl(i, 4)
のコードでエラーになります。
そのため、どのように処理したいのかをきちんと説明していただきたいところです。
(かみちゃん) 2009-04-28 8:07
こんにちは。かみちゃん です。
> うまく行きませんでした
そもそも、どううまく行かないのかがよくわかりませんが、HANAさんご提示のコードを私なりに修正すると、 以下の★の行の追加修正になります。 なお、☆の行は、私の環境では、変数ktiの種類が３つ以上になると「インデックスが有効範囲にありません。」 というエラーになるための対策もしています。
このあたりは、私の勘違いかもしれませんし、HANAさんから見解があるかもしれません。
Sub sin5()
Dim xi As Long
Dim kti As String
Dim tbl, x, dic, ca
Dim i As Long, ii As Long
ca = Array("C", "I") '<--ここに先頭の列番号を記入
Set dic = CreateObject("Scripting.Dictionary")
'--- 結果出力表の配列の確保
For ii = 0 To UBound(ca) '★
i = Range(ca(ii) & Rows.Count).End(xlUp).Row - 2 '★
If i <= 2 Then '★
i = 0 '★
End If '★
xi = xi + i '★
Next '★
If xi > 0 Then '★
ReDim x(1 To xi, 1 To 4) '★
xi = 0 '★
Else '★
MsgBox "データがありません" '★
Exit Sub '★
End If '★
'---------
For ii = 0 To UBound(ca)
If Range(ca(ii) & Rows.Count).End(xlUp).Row - 2 > 0 Then
tbl = Range(ca(ii) & "3").Resize(Range(ca(ii) & Rows.Count).End(xlUp).Row - 2, 4).Value
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
' If UBound(x, 1) < xi Then
' ReDim Preserve x(1 To UBound(x, 1) + UBound(tbl, 1), 1 To 3)
' End If
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = tbl(i, 3)
x(xi, 4) = tbl(i, 4) '★
Else
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
x(dic(kti), 4) = x(dic(kti), 4) + tbl(i, 4) '★
End If
Next
End If
Next
Range("M3").Resize(Range("M3").End(xlDown).Row - 2, 4).ClearContents '★
If xi > 0 Then Range("M3").Resize(xi, 4).Value = x '★
Set dic = Nothing
MsgBox "処理が終わりました。"
End Sub
なお、このコードでも、 C列とD列の組み合わせ、I列とJ列の組み合わせが同一の場合で、E列とK列、F列とL列に、文字と数値が混在していると
x(dic(kti), 3) = x(dic(kti), 3) + tbl(i, 3)
x(dic(kti), 4) = x(dic(kti), 4) + tbl(i, 4)
のコードでエラーになのは、一緒です。
(かみちゃん) 2009-04-28 8:36
To,かみちゃんさんへ ＞ReDim Preserve x(1 To UBound(x, 1) + UBound(tbl, 1), 1 To 3) ＞という処理をしていますが、このコードで「インデックスが有効範囲にありません」 ＞というエラーになりませんか？ 成りますね。失礼しました。
行列を入れ替えて、Transposeで書き出せば良さそうですが 変更コードの提示は、なさりたいことを実際にお伺いしてからにする事にします。
前にも書いたと思いますが、現行の他人のコードや数式に 手を加えて載せてしまうと、誰が作ったものなのか分かりにくくなります。 すでにあげられたものの変更のみに留める場合や、 根幹でそのロジックを使った方が良い 等で有れば、充分許容の範囲内でしょうし 状況にも大いに左右されるとは思いますが 人によって処理方法は異なってきますので、今回の様な場合は 発表はお控え頂ければと思います。 （ご自身で作成して、本人が修正コードを発表したときに 「同じ処理だな」とか「この人はこうやるのか」とか思えば良いだけですよね？）
To,しんさんへ これからコードを作っていっても、 さらに要望が出てくると思いますので 今の内に考えてみて下さい。 例えば「M列以降に書き出した後、必要範囲のみ罫線を引きたい」等は 多くの質問者さんがなさる追加要望です。 もちろん、特に無いのでしたら良いですが。
かみちゃんさんと質問が被る部分が有りますが、疑問点を載せておきます。 １．E:F列、K:L列に文字列が入っていますが、実際も文字列も混ざった状態で 実行するのですか？ ２．E,F,K,L列は全て O列に加算されれば良いのですか？ ３．E,F,K,L列には「分」の単位で入力されているのだと思いますが O列にも「分」で出れば良いのですか？それとも「○○：××」の様に 表示させるのがご希望でしょうか？
関係ないと思うことでも、省略せずに 説明する様にして下さい。
見出しは多くの場合、計算には関係有りません。 しかし、コードを作成する際の重要な情報に成ります。 ＞見出しはありません。 と言う事でしたが、2行目やA:B,G:H列が見出しですよ。
(HANA)
> A1～C1にあたるのがC3～E3でC50～E50までとI3～K3でI50～E50まであります。 > C50～E50の次がI3～K3からになります。
なんかよくわからないけど。
Sub test()
Dim a, w(), i As Long, ii As Long, z As String
a = Range("c3:k50").Value
With CreateObject("Scripting.Dictionary")
For i = 1 To 2
For ii = 1 To UBound(a, 1)
z = Join$(Array(a(i, IIf(i = 1, 1, 8)), _
a(i, IIf(i = 1, 2, 9))), ";")
If Not .exists(z) Then
.item(z) = VBA.Array(a(i, IIf(i = 1, 1, 8)), _
a(i, IIf(i = 1, 2, 9)), 0)
End If
w = .item(z)
w(2) = w(2) + a(i, IIf(i = 1, 3, 9))
.item(z) = w
Next ii, i
Range("m:o").ClearContents
Range("m3").Resize(.count, 3).Value = _
Application.Transpose(Application.Transpose(.items))
End With
End Sub
(seiya)
こんにちは。かみちゃん です。
> 前にも書いたと思いますが、現行の他人のコードや数式に > 手を加えて載せてしまうと、誰が作ったものなのか分かりにくくなります。
そうでしょうか？ 前にも教えていただいたと思いますが、「早い解決につながるのなら」という思いだけで、まぜっかえすつもりはありません。 そのため、プロシージャ名も変えていますし、こちらでUPされたファイルを恐る恐るダウンロードして検証もしています。 ご迷惑ならば、このスレッドに関しては、私のコードに対してのみ言及することにします。
>「同じ処理だな」とか「この人はこうやるのか」とか思えば良いだけですよね
そうかもしれません。 今回の場合は、Dictionaryオブジェクトを使って、複数の列を集計する方法について、勉強させていただきました。 seiyaさんのコードも拝見して、item で配列を使うには、このようにすればいいのだなと勉強させていただきました。
では、しんさんから、期待している結果の説明をお待ちしています。
(かみちゃん) 2009-04-28 9:39
> そうでしょうか？ そうだと思います。 (seiya)
こんにちは。かみちゃん です。
To.seiya さん
>> そうでしょうか？ > そうだと思います。
そうですか。 私は、HANAさんに聞いているのであって、seiyaさんに対しては何も触れていないつもりです。
いずれにしても、時間もなくなってきたので、 このスレッドに関しては、私のコードに対してのみ言及することにしますが、時間ができて、「早い解決につながる」のならば また、発言するかもしれません。 ご迷惑でしょうから、できるだけ控えるようにはしますが・・・
(かみちゃん) 2009-04-29 9:57
みなさんいろいろとお世話になっております・・。 理想の結果を入力しました。 http://firestorage.jp/download/4031d0895aa2b9bb371c05bb06c021459176201d 見てみてください。 宜しくお願いします。 (しん)
To,かみちゃんさん 今回、かみちゃんさんの行為が「まぜっかえしている」とは思いません。 しかし「早い解決につながるのなら」と言う事で有れば ご自身が作成し載せられたコードで解決するはずですよね？ 人のコードに手を加えたものを、さらに載せる必要は無いと思います。 （同じ結果に成るなら、なおさらです。）
マクロの名前を変更した所で（でも、連番ってのも問題有ですよね。） 元は私が書いたコードであることに変わりはありません。 このスレを離れてまで、或いはずいぶん後になってまで 「私が作ったの！！」と言う気は有りませんが まだ発展中のコードですので、自分の手で大切に育てて行ってやりたいと思います。 （完成後、手を離れたものは 寧ろ好きにしてもらいたいですが。）
かみちゃんさんは、ご自身のコードをどの様に考えて居られるか分かりませんが 私は有る程度美意識を持っています。また、大切な創造物です。 意味のないことかもしれませんが コードを書き終えた後、 体裁を整えるだけに非常に時間を掛けたりします。 それらも含め、意図しない手を加えられるのは、不本意です。
先にも書きましたが、「状況による」これは第一条件です。 載せる必要が有るのか、載せておいた方が良いのか、載せなくても良いのか。 その辺りの判断を 充分行っていただければと思います。 このスレ以外に関してもです。
色々書いていたら、しんさんが 希望出力結果を載せられたようですので 私もコードを載せておきます。 行数など、確定部分は定数に変更しましたので、 sin3の問題の部分は削除に成りました。
'------
Sub sin()
Dim xi As Long, i As Long
Dim kti As String
Dim tbl, x, dic, rng
Set dic = CreateObject("Scripting.Dictionary")
ReDim x(1 To 50 * 2, 1 To 4)
For Each rng In Array("C3:F50", "I3:L50")
tbl = Range(rng).Value
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If kti <> "_" Then
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
End If
x(dic(kti), 3) = x(dic(kti), 3) + IIf(IsNumeric(tbl(i, 3)), tbl(i, 3), 0)
x(dic(kti), 4) = x(dic(kti), 4) + IIf(IsNumeric(tbl(i, 4)), tbl(i, 4), 0)
End If
Next
Next
Range("M3").Resize(Range("M3").End(xlDown).Row - 2, 4).ClearContents
If xi > 0 Then Range("M3").Resize(xi, 4).Value = x
Set dic = Nothing
MsgBox "処理が終わりました。"
End Sub
'------
(HANA)
こんにちは。かみちゃん です。
> 理想の結果を入力しました。
しんさんが提示されたコードに対して、私が修正提案してきたコードを元にするならば、以下のような感じでできると思います。
Sub sin4_1() Dim xi As Long Dim kti As String Dim tbl, x, dic Dim i As Long
Dim rngTbl(1) As Range Dim j As Integer
Const clngRow As Long = 48 'C3:E50,I3:K50 は48行
Set rngTbl(0) = Range("C3").Resize(clngRow, 4)
Set rngTbl(1) = Range("I3").Resize(clngRow, 4)
ReDim x(1 To clngRow * 2, 1 To 4)
Set dic = CreateObject("Scripting.Dictionary")
For j = 0 To 1
tbl = rngTbl(j).Value
For i = 1 To UBound(tbl, 1)
kti = tbl(i, 1) & "_" & tbl(i, 2)
If kti <> "_" Then
If Not dic.exists(kti) Then
xi = xi + 1
dic(kti) = xi
x(xi, 1) = tbl(i, 1)
x(xi, 2) = tbl(i, 2)
x(xi, 3) = Val(tbl(i, 3)) '◆
x(xi, 4) = Val(tbl(i, 4)) '◆
Else
x(dic(kti), 3) = x(dic(kti), 3) + Val(tbl(i, 3)) '◆
x(dic(kti), 4) = x(dic(kti), 4) + Val(tbl(i, 4)) '◆
End If
End If
Next
Next
Range("M3", Range("M3").End(xlDown)).Resize(, 4).ClearContents '◆
If xi > 0 Then Range("M3").Resize(xi, 4).Value = x
Set dic = Nothing MsgBox "処理が終わりました" End Sub
tbl(i, 3) と tbl(i, 4) をval関数で数値にすると文字列の場合は、0になねことを利用しています。
HANAさん、seiyaさんが修正提案されたコードについては、解決方法がわかりましたが、現時点では発言は控えさせていただきます。
To.HANAさん
今、やっと気づきましたが、上記コードは、元々、HANAさんが提示されたコードを、しんさんが 修正されたのを見て、私がさらに修正提案をしてまったのですね。 そういう点では、私が口出すべき話ではなかったです。 「早い解決につながる」のであればという思いが、そうさせてしまったのだと思いますが、申し訳ありませんでした。
なお、私は、ファイルを見ていれば、Dictionaryオブジェクトの解決を考えましたが、 掲示板の内容だけで、そこまで思いつきませんでした。 そのため、勉強してみようと思い立って、ある程度わかったのですが、結局自分のアイデアは、出てきませんでした。
よって、甚だ勝手ながら、このあたりで、このスレッドからは撤退させていただきます。 ご迷惑おかけしました。今後ともよろしくお願いします。
(かみちゃん) 2009-04-28 10:35
> そうですか。 > 私は、HANAさんに聞いているのであって、seiyaさんに対しては何も触れていないつもりです。
> いずれにしても、時間もなくなってきたので、 > このスレッドに関しては、私のコードに対してのみ言及することにしますが、時間ができて、「早い解決につながる」のならば > また、発言するかもしれません。 > ご迷惑でしょうから、できるだけ控えるようにはしますが・・・
私の投稿に関しては一切ご無用ですのでご遠慮願います。 (seiya)
こんにちは。かみちゃん です。
To. seiyaさん
> 私の投稿に関しては一切ご無用ですのでご遠慮願います。
誤字等を除いて、他のスレッドも含めて最初からそのつもりですので、ご安心ください。 コードの誤字等があれば、時間がある限り、お構いなしに書き込みさせていただきます。 (最近は時間もないので、それもできないと思いますので、ご安心いただければと思います)
では、これにて失礼します。
(かみちゃん) 2009-04-28 10:52
あらら、遅かったけど、、、まぁ 載せておきましょうね。
To,かみちゃんさん 私が言っているのは sin2,sin4 の事ではなく sin5 の事です。 （どうも思い違いが有る様ですので。）
sin2,sin4は、かみちゃんさんのコードです。 （名前の付け方は問題有ると思いますが それも ＞今、やっと気づきましたが と言う事で有れば 仕様がない所だと思います。 ただ、記事はしっかり読んで下さいね。）
(HANA)
こんにちは。かみちゃん です。
言われたまま返答しないのは失礼なので、一応返答しておきます。
> ただ、記事はしっかり読んで下さいね
たぶん、私は、記事をしっかり読めていないようです。読解力に欠けているのだと思います。 ベースは、HANAさんが提示されたコードですので、私のコードではないつもりです。 sin5は、HANAさんからの書き込みがあるまでのつなぎのつもりでした。
思い違いの意味するところがよくわかりませんが、 いずれにしても、ご迷惑おかけしました。
(かみちゃん) 2009-04-28 11:01
すみません・・てっきり結果報告したつもりでいました。。 本当にすみませんでした。 結果は思い通りのものでした。みなさんどうもありがとうございましたm(__)m
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.