[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『『以下の場合、どのようなVBAコードになるでしょうか？』（CBR1000RR） その２』（CBR1000RR）
『以下の場合、どのようなVBAコードになるでしょうか？』（CBR1000RR）
以下のような実行結果が出力されるマクロコードを教えて頂きたく。
元ファイル
|C |G|M |Q 3 |P01|1|○|SD2,5-FAEFA-34P-DS 4 |P01|2|○|D-SW2,5-WWEFD 5 |P01|1|○|SD2,5-FAEFA-23P-DS 6 |P01|2| |D-SW2,5-WWEFD 7 |P01|1|○|SD2,5-FAEFA-100P-DS 8 |P01|2|○|D-SW2,5-WWEFD 9 |P01|1| |SD2,5-FAEFA-98P-DS 10|P01|2| |D-SW2,5-WWEFD 11|P01|1|○|SD2,5-FAEFA-3P-DS 12|P01|2|○|D-SW2,5-WWEFD 13|P01|1|○|SD2,5-FAEFA-32P-DS 14|P01|1| |SD2,5-34P-AS 15|P01|2|○|D-SW2,5 16|P01|1|○|SD2,5-100P-AS 17|P01|2|○|D-SW2,5 18|P01|1|○|SD2,5-36P-AS 19|P01|2|○|D-SW2,5 20| | | | 21| | | | 23| | | | 24| | | | 25| | | | 26| | | | 27| | | | 28|P20|1|○|SD2,5-FAEFA-34P-DS 29|P20|2|○|D-SW2,5-WWEFD 30|P20|1|○|SD2,5-FAEFA-64P-DS 31|P20|2|○|D-SW2,5-WWEFD
実行結果
|C |G|M |Q 3|P01|1|○|SD2,5-FAEFA-192P-DS 4|P01|6|○|D-SW2,5-WWEFD 5|P01|1|○|SD2,5-136P-AS 6|P01|6|○|D-SW2,5 7|P20|1|○|SD2,5-FAEFA-98P-DS 8|P20|4|○|D-SW2,5-WWEFD
の続きトピになります。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
要件が、任意の文字列パターン（でも、任意の特定文字列と数字と別の任意の特定文字列 という並び）を任意の数だけ与えたいということなら 以下のタイプＡでお試しください。 そうではなく、前半の特定文字列が複数あり、そのあと数字、続いて 後半の特定文字列が複数。 で、前半の特定文字列と後半の特定文字列の組み合わせは任意ということなら以下のタイプＢで試してください。
（そちらがアップされたパターン例は、そのいずれとでも受け取れる内容でしたので）
ところで、SD2,5-FAEFA- や P-DS 等、特定文字列を指定するうえで、もし、その文字列中に
^ $ ? * + . | { } \ [ ] ( )
こんな文字が含まれている場合、それは正規表現処理にとって、特殊な制御文字（メタ文字）とみなされますので、 \ をつけて（たとえば \+ や \( といったように）記述してくださいね。
●タイプＡ SubProc 入れ替え
Sub subProc(ws As Worksheet, dic As Object, dicG As Object, dicAC As Object, reg As Object)
Dim c As Range
Dim key As Variant
Dim n As Long
Dim w As Variant
Dim x As Long
Dim mt As Object
Dim rep As String
Dim hit As Boolean
Dim patQ As String
Dim patD As String
Dim nD As Variant
Dim cols As Long
Dim d As Variant
Dim y As Long
dic.RemoveAll
dicG.RemoveAll
dicAC.RemoveAll
patQ = "(SD2,5-FAEFA-)(\d+)(P-DS)|(SD2,5-)(\d+)(P-AS)|(SD2,5-FAEFA-)(\d+)(P-AS)|(SD2,5-)(\d+)(P-DS)"
patD = "^\d+" '先頭の数字
'各行の C,D(先頭の数字),Q(特定文字列は数値を除外したもの),R をキーとして集約
With ws
If .Range("AC2").Value = "" Then
.Range("AC2").Value = "NUMBER"
End If
If .Range("AD2").Value = "" Then
.Range("AD2").Value = "PLAE"
End If
cols = .Range("A1", .UsedRange).Columns.Count
reg.Pattern = patD
nD = Empty
If reg.test(.Range("D3").Value) Then nD = reg.Execute(.Range("D3").Value)(0)
'M列空白セルの行削除
On Error Resume Next
.Range("A1", .UsedRange).Offset(2).Columns("M").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
For Each c In .Range("C3", .Range("C" & Rows.Count).End(xlUp))
reg.Pattern = patQ
With c.EntireRow
key = .Range("Q1").Value
n = 0
hit = False
Set mt = reg.Execute(key)
If mt.Count > 0 Then
hit = True
For y = 0 To mt(0).submatches.Count - 1 Step 3
If Not IsEmpty(mt(0).submatches(y)) Then
n = mt(0).submatches(y + 1)
key = reg.Replace(key, "$" & y + 1 & vbTab & "$" & y + 3)
Exit For
End If
Next
.Range("Q1").Value = key
End If
key = .Range("C1").Value & vbLf & nD & vbTab & key & vbTab & .Range("R1").Value
If Not dic.exists(key) Then
dicAC(c.Value) = dicAC(c.Value) + 1
.Range("AC1").Value = nD & "-" & c.Value & "-" & dicAC(c.Value)
If c.Value = "S01" Then
.Range("AD1").Value = "M_MERKER"
Else
.Range("AD1").Value = "B_MERKER"
End If
dic(key) = c.EntireRow.Resize(, cols).Value
End If
If dicG.exists(key) Then
w = dicG(key)
Else
w = Array(0, 0)
End If
w(0) = hit
If hit Then
w(1) = w(1) + n
Else
w(1) = w(1) + .Range("G1").Value
End If
dicG(key) = w
End With
Next
'シート再作成
For Each key In dic
d = dic(key)
w = dicG(key)
If w(0) Then 'Q列特定文字列
d(1, Columns("G").Column) = 1 '常に 1
'特定文字列内の数値を合計値で置換
If d(1, Columns("Q").Column) Like "*" & vbTab & "*" Then d(1, Columns("Q").Column) = Replace(d(1, Columns("Q").Column), vbTab, w(1))
Else
d(1, Columns("G").Column) = w(1) 'G列合計
End If
dic(key) = d
Next
.Range("A1", .UsedRange).Offset(2).ClearContents 'シートの3行目以降をクリア
'dic に生成した変換シートイメージを一括転記
.Range("A3").Resize(dic.Count, cols).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
'C列で並び替え
.Range("C3", .Range("C" & Rows.Count).End(xlUp)).Offset(, -2).Resize(, cols).Sort Key1:=.Range("C3"), Order1:=xlAscending, Header:=xlNo
End With
End Sub
●タイプＢ SubProc 入れ替え
Sub subProc(ws As Worksheet, dic As Object, dicG As Object, dicAC As Object, reg As Object)
Dim c As Range
Dim key As Variant
Dim n As Long
Dim w As Variant
Dim x As Long
Dim mt As Object
Dim rep As String
Dim hit As Boolean
Dim patQ As String
Dim patD As String
Dim nD As Variant
Dim cols As Long
Dim d As Variant
dic.RemoveAll
dicG.RemoveAll
dicAC.RemoveAll
patQ = "(SD2,5-FAEFA-|SD2,5-)(\d+)(P-DS|P-AS)" '
patD = "^\d+" '先頭の数字
'各行の C,D(先頭の数字),Q(特定文字列は数値を除外したもの),R をキーとして集約
With ws
If .Range("AC2").Value = "" Then
.Range("AC2").Value = "NUMBER"
End If
If .Range("AD2").Value = "" Then
.Range("AD2").Value = "PLAE"
End If
cols = .Range("A1", .UsedRange).Columns.Count
reg.Pattern = patD
nD = Empty
If reg.test(.Range("D3").Value) Then nD = reg.Execute(.Range("D3").Value)(0)
'M列空白セルの行削除
On Error Resume Next
.Range("A1", .UsedRange).Offset(2).Columns("M").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
For Each c In .Range("C3", .Range("C" & Rows.Count).End(xlUp))
reg.Pattern = patQ
With c.EntireRow
key = .Range("Q1").Value
n = 0
hit = False
Set mt = reg.Execute(key)
If mt.Count > 0 Then
hit = True
key = reg.Replace(key, "$1" & vbTab & "$3")
n = mt(0).submatches(1)
.Range("Q1").Value = key
End If
key = .Range("C1").Value & vbLf & nD & vbTab & key & vbTab & .Range("R1").Value
If Not dic.exists(key) Then
dicAC(c.Value) = dicAC(c.Value) + 1
.Range("AC1").Value = nD & "-" & c.Value & "-" & dicAC(c.Value)
If c.Value = "S01" Then
.Range("AD1").Value = "M_MERKER"
Else
.Range("AD1").Value = "B_MERKER"
End If
dic(key) = c.EntireRow.Resize(, cols).Value
End If
If dicG.exists(key) Then
w = dicG(key)
Else
w = Array(0, 0)
End If
w(0) = hit
If hit Then
w(1) = w(1) + n
Else
w(1) = w(1) + .Range("G1").Value
End If
dicG(key) = w
End With
Next
'シート再作成
For Each key In dic
d = dic(key)
w = dicG(key)
If w(0) Then 'Q列特定文字列
d(1, Columns("G").Column) = 1 '常に 1
'特定文字列内の数値を合計値で置換
If d(1, Columns("Q").Column) Like "*" & vbTab & "*" Then d(1, Columns("Q").Column) = Replace(d(1, Columns("Q").Column), vbTab, w(1))
Else
d(1, Columns("G").Column) = w(1) 'G列合計
End If
dic(key) = d
Next
.Range("A1", .UsedRange).Offset(2).ClearContents 'シートの3行目以降をクリア
'dic に生成した変換シートイメージを一括転記
.Range("A3").Resize(dic.Count, cols).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
'C列で並び替え
.Range("C3", .Range("C" & Rows.Count).End(xlUp)).Offset(, -2).Resize(, cols).Sort Key1:=.Range("C3"), Order1:=xlAscending, Header:=xlNo
End With
End Sub
（β） 2016/02/07(日) 18:21
元スレにも投稿済みですが、例題のデータから期待値への変換は下記コードでできています。
他に条件変更等あれば、対応はしやすいと思いますよ？
Sub test()
Dim a, i As Long, ii As Long, x, temp As String, dic As Object, myNum As Long
Set dic = CreateObject("Scripting.Dictionary")
Wit [a3].CurrentRegion.Resize(, 17)
x = Filter(Evaluate("transpose(if(" & .Columns(13).Address & _
"=""○"",row(1:" & .Rows.Count & "),char(2)))"), Chr(2), 0)
a = Application.Index(.Value, Application.Transpose(x), [{3,7,13,17}])
End With
With CreateObject("VBScript.RegExp")
.Pattern = "(SD2,5(-FAEFA)?-)(\d+)(P-[AD]S)$"
For i = 1 To UBound(a, 1)
If .test(a(i, 4)) Then
temp = Join(Array(.Replace(a(i, 4), "$1$4"), a(i, 1)), Chr(2))
If Not dic.exists(temp) Then
dic(temp) = dic.Count + 1
SwapArray a, dic.Count, i
Else
myNum = Val(.Replace(a(i, 4), "$3")) + Val(.Replace(a(dic(temp), 4), "$3"))
a(dic(temp), 4) = .Replace(a(dic(temp), 4), "$1" & myNum & "$4")
End If
Else
temp = Join(Array(a(i, 4), a(i, 1)), Chr(2))
If Not dic.exists(temp) Then
dic(temp) = dic.Count + 1
SwapArray a, dic.Count, i
Else
a(dic(temp), 2) = a(dic(temp), 2) + a(i, 2)
End If
End If
Next
End With
Sheets.Add.Cells(1).Resize(dic.Count, 4).Value = a
End Sub
Private Sub SwapArray(a, ref As Long, i As Long)
Dim ii As Long
For ii = 1 To UBound(a, 2)
a(ref, ii) = a(i, ii)
Next
End Sub
FileをUL http://firestorage.jp/download/b132c2f9d1e4cb5829af169a9ac654a93564fb8d ダウンロードパスワード yedvxw7e （seiya） 2016/02/07(日) 20:53
失礼します。
seiyaさんのパターン、いつもながら感服なんですが、質問者さんのアップされたケースが、もしかしたら【たまたま】のケースかなと。 なので、私がアップしたコードも、２つの解釈をしていまして、どちらが、本当なのか、あるいは、どちらも勘違いなのか。 もしかしたら、seiyaさんの解釈、つまり
最初の文字列は SD2,5- もしくは SD2,5-FAEFA- いずれか。（FAEFA- があるケースとないケースだけ） 後ろの文字列は P-DS か P-AS いずれか。違いは D か A か というところだけ。
このように限定されているというのが、正しい解釈なのかもしれませんね。
ちなみに、私は
AAA 数字 XXX BBB 数字 YYY CCC 数字 ZZZ
といったように任意の文字列を複数与えたいのかな？（これが私がアップした タイプＡです）
ないしは
最初の文字列は AAA または BBB または CCC。 後ろの文字列は XXX または YYY。 最初の文字列と後ろの文字列の組み合わせは任意。 AAA 数字 YYY もマッチ、CCC 数字 XXX もマッチ。
というようなことなのかな？と。（これが私がアップした タイプＢです）
このあたりは、質問者さんから明確な要件の定義を聞かせていただきたいところです。
（もちろん、質問者さんが、正規表現のパターンの与え方については熟知していて、実際に抽出したい文字列要件に従って 適切なパターンを随時組み立てられるなら、どんな解釈云々という話ではないのですけど）
（β） 2016/02/07(日) 21:46
元スレに >⇒特定の文字列はSD2,5-FAEFA-(数値)P-DSとSD2,5-(数値)P-ASの二つのみです。 この二つ以外は存在しないと考えて下さい。 との明確な記述があったので、それに基づいて書いたコードです。 （seiya） 2016/02/07(日) 21:59
返答遅くなってしまい、すみません。
タイプAで問題なく動作しました。
タイプBも必要な場面は十分にありそうですので、その際は利用させてもらいます。
非常に長く、お付き合い頂き、有難う御座います。
本当に助かりました！！
（CBR1000RR） 2016/02/08(月) 10:39
返答遅くなってしまい、すみません。
こちらのコードも非常に助かりました。
御助力頂き、有難う御座います。
（CBR1000RR） 2016/02/08(月) 10:41
>御助力頂き、有難う御座います。
この質問にもっと早く気が付いていれば... 私のコードは簡単・簡潔に書いてあるのでStep Debug すれば理解できると思いますよ？ （seiya） 2016/02/08(月) 10:54
いえいえ、回答頂けただけでも助かります。
上記デバックにて確認してみます。
ありがとうございます。
（CBR1000RR） 2016/02/08(月) 13:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.