[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで条件ごとに文字を合体する』（難しい）
教えてください。
下記のような表があります。
やりたい事は、まずA列の名前を「;」で区切って合体して、その結果をA1セルに書きたいです。
Aさん;Bさん;Cさんとなる。
次に、C列の分類がaの行のB列の文字も「;」で合体して、A1セルにさらに合体したい。
A1セルの結果を、「Aさん;Bさん;Cさん;Dさん;Gさん;Hさん」としたい。
それぞれ単独には出来たのですが、両方を合体するにはどうすればいいかを教えて欲しいです。
また、別案でもっとシンプルなコードがあればぜひ教えてください。
あと、A列合体マクロの方ですが、下記事例の場合は正しく動くのですが、
もし3行目に1つだけ文字があって4行目以降空欄の場合（つまり合体するものが1つしかない）と、
dataArr = Range("A3:A" & lastRow).Value の部分で型が一致しませんと出ます。
更に、3行目以降全て空欄の場合、なぜかA1セルにはき出される結果は「名前」と書かれます。これらも解決しつつ、B列の条件にあう文字も合体する方法が分かれば教えて欲しいです。
A列 B列 C列 1 2 名前 名前 分類 3 Aさん Dさん a 4 Bさん Eさん b 5 Cさん Fさん c Gさん a Hさん a Iさん b
Sub A列合体マクロ()
Dim lastRow As Long
Dim dataArr() As Variant
Dim concatString As String
Dim i As Long
' A列の最終行を取得
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
' A列のデータを配列に読み込み
dataArr = Range("A3:A" & lastRow).Value
' 文字列を合体
For i = 1 To UBound(dataArr, 1)
If Not IsEmpty(dataArr(i, 1)) Then
If concatString <> "" Then
concatString = concatString & ";" & dataArr(i, 1)
Else
concatString = dataArr(i, 1)
End If
End If
Next i
' 結果をA1セルに書き込む
Range("A1").Value = concatString
End Sub
Sub B列合体マクロ()
Dim lastRow As Long
Dim dataArr() As Variant
Dim concatString As String
Dim i As Long
' A列の最終行を取得
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
' A列とB列のデータを配列に読み込み
dataArr = Range("B3:C" & lastRow).Value
' 文字列を合体
For i = 1 To UBound(dataArr, 1)
If Not IsEmpty(dataArr(i, 2)) And dataArr(i, 2) = "a" Then
If concatString <> "" Then
concatString = concatString & ";" & dataArr(i, 1)
Else
concatString = dataArr(i, 1)
End If
End If
Next i
' 結果をA1セルに書き込む
Range("A1").Value = concatString
End Sub
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
E2 =TRANSPOSE(TEXTJOIN(";",TRUE,A3:A8,FILTER(B3:B8,C3:C8="a","")))
|[A] |[B] |[C] |[D]|[E]
[1]| | | | |
[2]|名前 |名前 |分類| |Aさん;Bさん;Cさん;Dさん;Gさん;Hさん
[3]|Aさん|Dさん|a | |
[4]|Bさん|Eさん|b | |
[5]|Cさん|Fさん|c | |
[6]| |Gさん|a | |
[7]| |Hさん|a | |
[8]| |Iさん|b | |
（フォーキー） 2024/01/24(水) 01:33:13
今回は一連のマクロの中で再現したいと思っているので、
引き続き、マクロの方もよろしくお願いします。
（難しい） 2024/01/24(水) 05:52:16
1. A3しかない場合への対応
姑息な手段かもしれないが、
dataArr = Range("A2:A" & lastRow).Value
と２行目から範囲にして、
For i = 2 To UBound(dataArr, 1)
としたらどうですか？
2．両者の統合
Function プロシージャにして、結果だけを文字列結合したらどうですか？
こんな感じです。
Sub test()
Dim s1 As String, s2 As String
s1 = A列合体マクロ
s2 = B列合体マクロ("a") '判定要素は引数で受け渡します
If s1 <> "" Then
If s2 <> "" Then
Range("A1") = s1 & ";" & s2
Else
Range("A1") = s1
End If
Else
Range("A1") = s2
End If
End Sub
3. ちなみに、A3がブランクといったエッジケースもあるなら、以下のようにします。
' A列の最終行を取得
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
If Range("A3") = "" Then Exit Function ' ←←■
' A列のデータを配列に読み込み
dataArr = Range("A2:A" & lastRow).Value
' 文字列を合体
For i = 2 To UBound(dataArr, 1)
実際のコードは、そちらでトライしてください。考え方が明らかなら、できるかと思います。
（xyz） 2024/01/24(水) 06:52:48
いくつか作ってみました。
1 数式をマクロ化（A列が空欄、B列対象なしでも動く）
Sub test()
Dim r As Long
r = Range("A2").CurrentRegion.Rows.Count
With Range("A1")
.Formula = "=TRANSPOSE(TEXTJOIN("";"",TRUE,A3:A" & r & ",FILTER(B3:B" & r & ",C3:C" & r & "=""a"","""")))"
.Value = .Value
End With
End Sub
2 A列をJoin関数で結合（A列に名前が2件以上ない場合は考慮してない）
Sub test2()
Dim buf As String, r As Long, i As Long
r = Cells(Rows.Count, "A").End(xlUp).Row
buf = Join(Application.Transpose(Range("A3", Cells(r, "A"))), ";")
For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "C") = "a" Then buf = buf & ";" & Cells(i, "B")
Next
Range("A1") = buf
End Sub
3 ベタベタに1件ずつ結合
Sub test3()
Dim r As Long, i As Long, buf As String
r = Cells(Rows.Count, "A").End(xlUp).Row
If r > 2 Then
For i = 3 To r
buf = buf & ";" & Cells(i, "A")
Next
End If
r = Cells(Rows.Count, "B").End(xlUp).Row
If r > 2 Then
For i = 3 To r
If Cells(i, "C") = "a" Then buf = buf & ";" & Cells(i, "B")
Next
End If
Range("A1") = Mid(buf, 2)
End Sub
（フォーキー） 2024/01/24(水) 06:59:59
フォーキー様
ありがとうございます。
数式織り込みや、1件ずつ結合も分かりやすいです。参考にさせて頂きます。
（難しい） 2024/01/24(水) 07:12:03
Sub 別案１()
Dim 行 As Long, c As Long
Dim 配列() As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "A").Value
c = c + 1
Next 行
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = "a" Then
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "B").Value
c = c + 1
End If
Next
End With
If (Not 配列) <> -1 Then
MsgBox Join(配列, ";")
Else
MsgBox "該当無し"
End If
End Sub
もちろん、１つの【文字列】でも可能です。（フォーキーさんの3と同じですが）
Sub 別案2()
Dim 行 As Long, c As Long
Dim 文字列 As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
文字列 = 文字列 & .Cells(行, "A").Value & ";"
Next 行
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = "a" Then
文字列 = 文字列 & .Cells(行, "B").Value & ";"
End If
Next
End With
If 文字列 <> "" Then
MsgBox Left(文字列, Len(文字列) - 1)
Else
MsgBox "該当無し"
End If
End Sub
（もこな２ ） 2024/01/24(水) 12:50:33
Sub Test()
Dim 行 As Long, c As Long
Dim 配列() As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "A").Value
c = c + 1
Next 行
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = "a" Then
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "B").Value
c = c + 1
End If
Next
If (Not 配列) <> -1 Then
.Cells(1, "A").Value = Join(配列, ";")
Else
MsgBox "該当無し"
End If
End With
Dim 行2 As Long, c2 As Long
Dim 配列2() As String
With ActiveSheet
For 行2 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Preserve 配列2(c2)
配列2(c2) = .Cells(行2, "A").Value
c2 = c2 + 1
Next 行2
For 行2 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行2, "C").Value = "b" Then
ReDim Preserve 配列2(c2)
配列2(c2) = .Cells(行2, "B").Value
c2 = c2 + 1
End If
Next
If (Not 配列2) <> -1 Then
.Cells(1, "B").Value = Join(配列2, ";")
Else
MsgBox "該当無し"
End If
End With
End Sub
（難しい） 2024/01/25(木) 23:41:17
面白そうなので参加！
Option Explicit
Sub 実行プロシジャ()
Debug.Print "A列で空白以外："; UDF_JOINIF([a3], [a3], "", False, ";")
Debug.Print "C列がaの場合B列を結合："; UDF_JOINIF([b3], [c3], "a", True, ";")
Debug.Print "C列がbの場合B列を結合："; UDF_JOINIF([b3], [c3], "b", True, ";")
Debug.Print "C列がcの場合B列を結合："; UDF_JOINIF([b3], [c3], "c", True, ";")
Debug.Print "C列がzの場合B列を結合："; UDF_JOINIF([b3], [c3], "z", True, ";")
End Sub
'ユーザー関数
Function UDF_JOINIF(ByVal join_range As Range, ByVal criteria_range As Range, ByVal criteria As String, include As Boolean, dlm As String) As String
Dim f As String
Dim r1 As Range
Dim r2 As Range
Dim v As Variant
'検索条件 完全一致がそれ以外のみ 以上、以下は未対応（Evaluate用の式）
If include Then
f = "=transpose(if(★=""▲"",■,char(2)))"
Else
f = "=transpose(if(★<>""▲"",■,char(2)))"
End If
'結合範囲の設定 例題のA3以降が空白の場合でも、A3以降のみしか取得しない
Set r1 = Intersect(join_range.Resize(Rows.Count - join_range.Row), Range(join_range(1), Cells(Rows.Count, join_range.Column).End(xlUp)))
'検索範囲の設定 結合範囲とサイズを合わせる
Set r2 = criteria_range(1).Resize(r1.Rows.Count)
'Evaluate用の式の組み立て
f = Replace(f, "■", r1.Address)
f = Replace(f, "★", r2.Address)
f = Replace(f, "▲", criteria)
'Evaluateを実行して、結果を配列で受け取る
v = Application.Evaluate(f)
'一致しない条件を削除
v = Filter(v, Chr(2), False)
'配列を結合して出力
UDF_JOINIF = Join(v, dlm)
End Function
（稲葉） 2024/01/26(金) 10:08:18
あえて Functionプロシージャ（この場合は、Sub プロシージャでもOKですが）を使うこともできる、 という例を示しておきます。 下記のtestプロシージャから、getDataプロシージャを呼び出しています。
なお、getDataに相当する部分が長大なものであったりする場合は特に、 主たるプロシージャーの流れが見えにくくなるので、 こうしたFunctionプロシージャ（やSubプロシージャ）を使うとよいでしょう。 ただ今回のような比較的短い場合は、下記のtest2のように書いてしまうと思います。 どちらも同じ結果が得られます。
なお、他のプロシージャへの引数の渡し方にも注目して下さい。 デフォルトだとByRefが省略されていると解釈されるので、いわゆる"参照渡し"です。 配列やその大きさを示す変数cを、親と子で共有することになります。 このあたりは、VBAのテキストなどに詳しく説明されているはずです。よく復習してみてください。
Sub test()
Dim 行 As Long, c As Long
Dim 配列() As String
Dim s As Variant
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "A").Value
c = c + 1
Next 行
For Each s In Array("a", "b", "c")
Call getData(s, 配列, c)
Next
.Cells(1, "A").Value = Join(配列, ";")
End With
End Sub
Function getData(s As Variant, 配列() As String, c As Long)
Dim 行 As Long
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = s Then
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "B").Value
c = c + 1
End If
Next
End With
End Function
Sub test2()
Dim 行 As Long, c As Long
Dim 配列() As String
Dim s As Variant
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "A").Value
c = c + 1
Next 行
For Each s In Array("a", "b", "c")
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = s Then
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "B").Value
c = c + 1
End If
Next
Next
.Cells(1, "A").Value = Join(配列, ";")
End With
End Sub
別法としては、 ・A列の名前、 ・B:C列を分類を優先キーにしてソートしたものを、 名前が同一列になるように配置し、 それに対して名前列を一次元配列にしたうえでJoinを取る、 などといった方法もあるでしょう。 （xyz） 2024/01/26(金) 12:14:53
Sub main()
Dim c As Range, r As Range
Rows(1).ClearContents
If Range("C3").Value = "" Then Exit Sub
Set r = Range("A1")
For Each c In Range("C3:C" & Rows.Count).SpecialCells(2)
If WorksheetFunction.CountIf(Range("C3:C" & c.Row), c.Value) = 1 Then
r.Value = "=TEXTJOIN("";"",TRUE,FILTER($B$3:$B$" & Rows.Count & ",$C$3:$C$" & Rows.Count & "=C" & c.Row & ",""""))"
r.Value = WorksheetFunction.TextJoin(";", True, Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))) & ";" & r.Value
Set r = r.Offset(, 1)
End If
Next c
End Sub
（ｍｍ） 2024/01/26(金) 13:07:19
稲葉様のコードでは、ユーザー関数にこのように定義できるのですね。
ありがとうございます。難しくてまだ理解できていませんが、一つずつ分解して調べてみます。
mm様のコードでは、関数で出来てしまうのですね。家のPCが365対応でないからか？エラーが出てしまうのでまた後日試してみます。ありがとうございます。
xyz様、引数の渡し方のご説明まで、ありがとうございます。今ちょうど引数や配列等を勉強中なので、大変参考になります。
すみません質問の仕方がよろしくなかったですが、結果はA1セルにa,b,cのケースを全てまとめるのではなく、
aの場合は合体したものをA1セルに、bの場合は合体したものをB1セルに、Cの場合はC3セルに…と条件ごとに結果を表示したいです。
下記の場合、
A1セルには条件aの場合「Aさん;Bさん;Cさん;Dさん;Gさん;Hさん」
B1セルには条件bの場合「Aさん;Bさん;Cさん;Eさん;Iさん」
C1セルには条件dの場合「Aさん;Bさん;Cさん;Fさん」
としたいです。
xyz様のコードの「For Each s In Array("a", "b", "c")」の部分を
If s = "a" then
のように書けないかとかいろいろ試したものの上手く再現できず。。。引き続きアドバイス頂けますと助かります。
A列 B列 C列 1 2 名前 名前 分類 3 Aさん Dさん a 4 Bさん Eさん b 5 Cさん Fさん c Gさん a Hさん a Iさん b
（難しい） 2024/01/26(金) 23:11:01
■１
＞次に、bの場合、cの場合もやりたいです。
そういう話であれば、【文字列】で考えた方がシンプルかもしれません。
その場合、A列から取得する処理は1回だけにするということも可能です。
また、"a"の部分が"b"や"c"に変わればよく、それ以外は使い回しできるので、分類の数だけB列の処理を書かなくても大丈夫です。
■２
上記を踏まえると↓のようなことでもよいと思います。
Sub 別案2_改()
Dim 行 As Long, c As Long
Dim 分類 As Variant
Dim A列文字列 As String, B列文字列 As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
A列文字列 = A列文字列 & .Cells(行, "A").Value & ";"
Next 行
B列文字列 = A列文字列
For Each 分類 In Array("a", "b", "c", "d")
B列文字列 = A列文字列
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = 分類 Then
B列文字列 = B列文字列 & .Cells(行, "B").Value & ";"
End If
Next 行
If B列文字列 <> "" Then
MsgBox "【分類 " & 分類 & " で抽出】" & vbLf & Left(B列文字列, Len(B列文字列) - 1)
Else
MsgBox "【分類 " & 分類 & " で抽出】" & vbLf & "該当無し"
End If
Next 分類
End With
End Sub
※１ 上記は説明のための提示であり、完成品プレゼントの意図はありません。 ※２ 採用される場合は【ステップ実行】等により研究の上、理解できてから必要な部分のみご自身のコードに組み込んでください。
■３
＞これをもっとシンプルにするには
何をもってシンプルとするか難しいところですが、上記の処理でいえばB列の処理を外だしにするという手はあると思います。
Sub 別案2_改二()
Dim 行 As Long
Dim 文字列 As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
文字列 = 文字列 & ";" & .Cells(行, "A").Value
Next 行
MsgBox "【分類 a で抽出】" & vbLf & Mid(文字列 & B列処理("a"), 2)
MsgBox "【分類 b で抽出】" & vbLf & Mid(文字列 & B列処理("b"), 2)
MsgBox "【分類 c で抽出】" & vbLf & Mid(文字列 & B列処理("c"), 2)
MsgBox "【分類 d で抽出】" & vbLf & Mid(文字列 & B列処理("d"), 2) 'A列にデータが無いとかっこ悪いので注意
End With
End Sub
'============================================
Function B列処理(分類 As String) As String
Dim 行 As Long
Dim 文字列 As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = 分類 Then
文字列 = 文字列 & ";" & .Cells(行, "B").Value
End If
Next 行
End With
B列処理 = 文字列
End Function
※こちらも研究素材として提供します。丸パクリして完成！というのはご遠慮ください。
■余談
話が飛躍しますが分類の数だけ処理をしたいということならば、まずはC列から重複のないリストを作成することを考えればよいでしょう。
混乱するとよろしくないのでリンク紹介に留めます。
【リンク】 http://officetanaka.net/excel/vba/tips/tips80.htm
（もこな２ ） 2024/01/26(金) 23:20:11
Sub Test()
Call ProcessData("a", "A")
Call ProcessData("b", "B")
Call ProcessData("c", "C")
End Sub
Sub ProcessData(targetValue As String, targetColumn As String)
Dim 行 As Long, c As Long
Dim 配列() As String
With ActiveSheet
For 行 = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "A").Value
c = c + 1
Next 行
For 行 = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(行, "C").Value = targetValue Then
ReDim Preserve 配列(c)
配列(c) = .Cells(行, "B").Value
c = c + 1
End If
Next
If (Not 配列) <> -1 Then
.Cells(1, targetColumn).Value = Join(配列, ";")
Else
MsgBox "該当無し"
End If
End With
End Sub
（難しい） 2024/01/26(金) 23:22:06
2つ目のコードのような分解方法もあるのですね。
自分のやりたい事を実現するにはどのようなフローでやるのかを、しっかりイメージして作れるかが重要ですね。そこが出来ていないので、意識していきたいと思います。
リンクのご提示もありがとうございます。
dictionaryもまだ勉強できていないので、引き出し増やしていければと思います。
（難しい） 2024/01/26(金) 23:40:10
この仕様で自分が作成するならというのを作成してみました。 参考になれば幸いです。
汎用性を考慮して下記の２つの関数を作成します。
指定したセル範囲のテキストを連結する関数 JoinRng (365なら TextJoin で代用可能)
指定したセル範囲の条件に一致したテキストを連結する関数 JoinIf
Public Function JoinRng(sourceRange As Range, delimiter As String) As String
Dim i As Long
For i = 1 To sourceRange.Cells.Count
JoinRng = JoinRng & delimiter & sourceRange.Cells(i)
Next
JoinRng = Mid(JoinRng, 2)
End Function
Public Function JoinIf(sourceRange As Range, criteriaRange As Range, criteria, delimiter As String) As String
Dim i As Long
For i = 1 To sourceRange.Cells.Count
If criteriaRange.Cells(i) = criteria Then
JoinIf = JoinIf & delimiter & sourceRange.Cells(i)
End If
Next
JoinIf = Mid(JoinIf, 2)
End Function
Public Sub Test()
Dim r1 As Range, r2 As Range
Set r1 = Range("A3", Cells(Rows.Count, "A").End(xlUp))
Set r2 = Range("B3", Cells(Rows.Count, "B").End(xlUp))
Dim s, c As Range
Set c = Range("A1") '出力起点セル
For Each s In Split("a b c")
c = JoinRng(r1, ";") & ";" & JoinIf(r2, r2.Offset(, 1), s, ";")
Set c = c.Offset(,1)
Next
End Sub
（hatena） 2024/01/27(土) 04:54:12
一つ教えてください。
関数の方もSubの方も先頭にPublicが付いていますが、これ取ってしまっても動きます。
実際は他の工程の中にこの処理を組み合わせたいです。
同じモジュール内にいくつかのFunctionやSubを組み合わせる場合、Dim等の設定もSubの更に上に置いて外に置いた方がいいのかとか、Publicを使うのがいいのかとか、その辺がネットでしらべるも実際の使いどころがいまいち分からず、、、
（難しい） 2024/01/27(土) 06:37:38
Publicを付けると、他のモジュールからも参照できます。 対して、Privateを付けるとそのモジュールでしか参照できません。 これはそのモジュールでしか使わない、あるいは使わせたくないプロシージャにつけます。 他にFriendというのもありますが、これはちょっと高度だし使う機会はほとんどないので、 興味があったら調べてみてください。
今回は汎用性を考慮してますので、どこからでも使えるように Public にしてます。
で、これらの宣言を省略すると Public として扱われます。 ですので、これを取ってしまっても同様に動きます。
（hatena） 2024/01/27(土) 10:05:32
Publicは省略してもPublic扱いになるので、Privateにしたい場合以外は省略でいいでしょう。
私の場合は、たいていAlt+I+Pでプロシージャの追加ダイアログから追加しますので、 その時に自動でPublicはついてきますので、わざわざ削除はしないです。 （hatena） 2024/01/27(土) 10:43:28
上記部分は、変数の適用範囲に関することだと思うので、
主題は違いますが、以下が参考になるかも。
[[20220924005855]]『モジュールレベルでの宣言』
変数の適用範囲
http://officetanaka.net/excel/vba/variable/05.htm
第108回.変数の適用範囲（スコープ,Private,Public）
https://excel-ubara.com/excelvba1/EXCELVBA408.html
（横から失礼） 2024/01/27(土) 12:22:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.