[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『文字列の再結合』（コニャック）
列を複数選択して結合する
B列から右方向に文字列が格納されています。
（列の個数は、DATAによって一定では無く可変する）
列から、いくつか指定して指定文字で連結して
指定列以外は、不要なので削除して列の最後尾に結合文字を書き出したい。
例えば、元DATAが以下の構成では
|[A] |[B]|[C] |[D] |[E] |[F] |[G]
[1]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|2nd|夢の一員になりたい|岡田達也 |黒田晃一郎|川島尚|高澤美佳
B列とC列を結合対象として結合する文字を「-」と指定したととすれば、以下のようにしたい
（結合対象でない列(C,D,E,F,G）は削除、結合文字列を一番右の列＝D列に書き出す）
| | | |
[1]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|2nd|夢の一員になりたい|2nd-夢の一員になりたい|
途中までコードを記載しました。
最後に指定列以外の不要な列を削除する簡単なコードが思いつきません。
何か？方法がありますか ？
又、コードに不備があればアドバイスお願いします。
Sub 再結合()
Dim sc As String
Dim sm As String
Dim scb As Byte
Dim scby As Variant
sc = InputBox("結合列の指定")
scb = Len(sc)
ReDim scby(scb)
Dim i As Byte
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
Dim km As String
km = InputBox("結合文字列指定")
Dim ii As Long
Dim lc As Long
Dim kmj As String
Dim temp As String
lc = Cells(Rows.Count, 1).End(xlUp).Row
For ii = 1 To lc
For i = 1 To scb
temp = Cells(ii, scby(i)) & km
kmj = kmj & temp
Next
Cells(ii, Cells(ii, Columns.Count).End(xlToLeft).Column) = kmj
Next
End Sub
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
分からないのは、今使用している列で必要列今回の場合では、＜A列とscby()で格納された列＞
以外の列をどんな方法で指定するかです。
つまり、以下では"F"をどのようにして指定するか ？
Cells(1, "F").EntireColumn.Delete
削除列は、可変で飛び飛びにある場合もあるので難しいです。
（コニャック） 2023/01/24(火) 10:24:25
Range(scby(iii)).EntireColumn
でエラーがでます。
Sub 再結合()
Dim sc As String
Dim sm As String
Dim scb As Byte
Dim scby As Variant
'結合列を複数選択(形式: bce)
sc = InputBox("結合列の指定")
scb = Len(sc) '選択列の総数
ReDim scby(scb)
Dim i As Byte
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
'結合する文字を指定
Dim km As String
km = InputBox("結合する文字を指定")
Dim ii As Long
Dim lc As Long
Dim lr As Byte
Dim kmj As String
Dim temp As String
lc = Cells(Rows.Count, 1).End(xlUp).Row
lr = Cells(1, Columns.Count).End(xlToLeft).Column
'再結合した文字列を最終列の横に書き出す
For ii = 1 To lc
For i = 1 To scb
temp = Cells(ii, scby(i)) & km
kmj = kmj & temp
Next
Cells(ii, lr + 1) = kmj
kmj = ""
Next
Stop
’不要列の削除
Dim iii As Byte
For iii = 2 To lr
If Columns(iii) <> Range(scby(iii)).EntireColumn Then
Columns(iii).Delete
End If
Next
End Sub
（コニャック） 2023/01/24(火) 10:53:48
（隠居Z） 2023/01/24(火) 10:54:40
Option Explicit
Sub 再結合_IZ01()
Dim sc As String
Dim sm As String
Dim scb As Long
Dim scby As Variant
Dim cAry() As Variant
Dim x As Long
Dim i As Long
Dim km As String
Dim ii As Long
Dim lc As Long
Dim lr As Long
Dim kmj As String
Dim temp() As Variant
Dim v() As Variant
Dim tmp As String
'結合列を複数選択(形式: bce)
sc = InputBox("結合列の指定")
scb = Len(sc) '選択列の総数
ReDim scby(scb)
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
'結合する文字を指定
km = InputBox("結合する文字を指定")
lc = Cells(Rows.Count, 1).End(xlUp).Row
lr = Cells(1, Columns.Count).End(xlToLeft).Column
'再結合した文字列を最終列の横に書き出す
For ii = 1 To lc
ReDim temp(1 To scb + 1)
For i = 1 To scb
temp(i) = Cells(ii, scby(i))
tmp = Cells(ii, scby(i)) & km
kmj = kmj & tmp
Next
kmj = Left(kmj, Len(kmj) - 1)
temp(UBound(temp)) = kmj
kmj = ""
ReDim Preserve cAry(x)
cAry(x) = temp
x = x + 1
Next
ReDim v(1 To UBound(cAry) + 1, 1 To UBound(cAry(0)))
For i = LBound(cAry) To UBound(cAry)
For ii = LBound(cAry(i)) To UBound(cAry(i))
v(i + 1, ii) = cAry(i)(ii)
Next
Next
ActiveSheet.UsedRange.Clear
Cells(1).Resize(UBound(v, 1), UBound(v, 2)) = v
End Sub
もっと解りやすい方法が有るとは存じますが。。。＾＾；
こんな感じでせうか。。。(#^^#)
老婆心ながら、シートは指定された方が何かと不測の事態防止の為には
良いかと存じますです。m(__)m
（隠居Z） 2023/01/24(火) 12:07:02
>削除列は、可変で飛び飛びにある場合もあるので難しいです。
↑、例えば、
>sc = InputBox("結合列の指定")
↑ここで、どんな指定をしたとき、
削除したい列はどうなるんですか？
具体例を2．3お願いしたいです。
（まっつわん） 2023/01/24(火) 13:20:34
隠居Zさんと同じで、一度配列に書き出してから元データを消して入れなおしてあげたほうが早いかなーと思ったり・・・
列の指定は、セルを選択してもらうように変更しました。
Sub 再結合2()
Dim dlm As String
Dim joinC As Range
Dim ws As Worksheet
Dim r As Long '行のループ用
Dim rc As Range '選択した列のループ用
Dim lr As Long '最終行
Dim ans As Variant '結果出力用配列
Dim buf As String '結合文字の作成用
Dim cnt As Long '列のカウント用
'//対話設定とエラー処理
dlm = InputBox("区切り文字を指定してください")
If Len(dlm) = 0 Then
MsgBox "区切り文字が指定されなかったため、処理を中断します"
End If
Set joinC = Application.InputBox("結合したい列を選択してください。飛び飛びは、Ctrl押しながら選択してください。", Type:=8)
If joinC Is Nothing Then
MsgBox "列が選択されなかったため、処理を中断します。"
Exit Sub
End If
'//基本データの取得
Set ws = joinC(1).Parent
Set joinC = Intersect(Rows(1), joinC.EntireColumn)
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
'//出力データの作成
ReDim ans(1 To lr, 1 To joinC.Count + 2) '+2は元データと結合文字の分
For r = 1 To lr
'1列目に元データを入れて、cntを初期化する
buf = ""
cnt = 1
ans(r, cnt) = ws.Cells(r, "A")
'指定した列を1行ずつ取り出し、結合を繰り返す
For Each rc In joinC.Offset(r - 1)
cnt = cnt + 1
ans(r, cnt) = rc.Value
buf = buf & rc.Value & dlm
Next rc
cnt = cnt + 1
ans(r, cnt) = Left(buf, Len(buf) - 1)
Next r
'//出力 デフォルトは新しいシートに出力
' ws.ClearContents '同じシートに書き出す場合、コメントアウトを外す
' With ws '同じシートに書き出す場合、コメントアウトを外す
With Sheets.Add(after:=Sheets(Sheets.Count)) 'デフォルトは新しいシートに出力、同じシートに書き出す場合は、コメントアウトする
.[a1].Resize(lr, UBound(ans, 2)).Value = ans
End With
MsgBox "出力しました"
End Sub
（稲葉） 2023/01/24(火) 13:32:03
隠居さんのコードで以下が私には難解なので少し噛み砕いて説明いただけないでしょうか？
（不必要な列を削除するのではなく、一度セルをキレイにして必要なセルだけ書き込むと言うのは理解できています。）
ReDim v(1 To UBound(cAry) + 1, 1 To UBound(cAry(0)))
For i = LBound(cAry) To UBound(cAry)
For ii = LBound(cAry(i)) To UBound(cAry(i))
v(i + 1, ii) = cAry(i)(ii)
Next
Next
ActiveSheet.UsedRange.Clear
Cells(1).Resize(UBound(v, 1), UBound(v, 2)) = v
まっつわんさん、問への回答です。
＞ここで、どんな指定をしたとき
例えば、最初の質問の例にあるB列とC列を結合対象にするなら
ｂｃをを指定することになります。
＞削除したい列はどうなるんですか？
一度削除した列は、復活などは無いので削除のままで問題ありません。
もしもに備えて元のDATAをA列に残しています。
＞具体例を2．3お願いしたいです。
以下で理解できますか？
整理前
|[A] |[B]|[C] |[D] |[E] |[F] |[G] |[H]
[4]|4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知 |4th|命かけて僕は生きたいんです |浦畑達彦 |中村哲治 |久藤瞬 |吉田正幸、服部憲知|
[5]|5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸 |5th|だから僕はこれからも走るよ風間くん|水上清資 |境宗久 |牧田佳織 |松岡秀明、南東寿幸|
[6]|6th-誰かのために走ります-それが僕の目指すサッカーです-ふでやすかずゆき-竹之内和久-えんどうてつや-北村友幸--|6th|誰かのために走ります |それが僕の目指すサッカーです|ふでやすかずゆき|竹之内和久|えんどうてつや |北村友幸
整理後（BC列を結合してD列へ 生理前ののD,E,F,G,Hは削除）
|[A] |[B]|[C] |[D]
[4]|4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知 |4th|命かけて僕は生きたいんです |4th-命かけて僕は生きたいんです
[5]|5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸 |5th|だから僕はこれからも走るよ風間くん|5th-だから僕はこれからも走るよ風間くん
[6]|6th-誰かのために走ります-それが僕の目指すサッカーです-ふでやすかずゆき-竹之内和久-えんどうてつや-北村友幸--|6th|誰かのために走ります |6th-誰かのために走ります
この例では、BCが対象ですが、飛び飛びでBDFなどの場合もありえる。
稲葉さんへコードありがとうございます。
隠居Zさんと稲葉さんのコードを同時に追いかける能力が無いので少し時間をください。
稲葉さんのコードにある程度の理解が出来てから稲葉さんのコードをゆっくり見たいと思います。
以下、隠居Zさんのコードをほぼ頂いて少し改良した現在のコードです。
（どうしても元のA列を残したいので仮シートを利用したコピペで対応しています。）
Sub 再結合_IZ01()
Dim sc As String
Dim sm As String
Dim scb As Long
Dim scby As Variant
Dim cAry() As Variant
Dim x As Long
Dim i As Long
Dim km As String
Dim ii As Long
Dim lc As Long
Dim lr As Long
Dim kmj As String
Dim temp() As Variant
Dim v() As Variant
Dim tmp As String
'結合列を複数選択(形式: bce)
sc = StrConv(InputBox("結合列の指定"), vbNarrow)
scb = Len(sc) '選択列の総数
ReDim scby(1 To scb)
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
'結合する文字を指定
km = StrConv(InputBox("結合する文字を指定"), vbNarrow)
lc = Cells(Rows.Count, 1).End(xlUp).Row
lr = Cells(1, Columns.Count).End(xlToLeft).Column
'再結合した文字列を最終列の横に書き出す
For ii = 1 To lc
ReDim temp(1 To scb + 1)
'temp()に1行分の再結合の文字列を追加しながら求める
For i = 1 To scb
temp(i) = Cells(ii, scby(i))
tmp = Cells(ii, scby(i)) & km
kmj = kmj & tmp
Next
kmj = Left(kmj, Len(kmj) - 1) '不要な最後の一文字削除
temp(UBound(temp)) = kmj 'temp()の最大要素数に1行分の再結合の文字列が有る
kmj = "" 'kmjの初期化
'temp()の最大要素数に1行分の再結合の文字列が有るので
'これを総行数分だけcAry()に記憶していく
ReDim Preserve cAry(x)
cAry(x) = temp
x = x + 1
Next
ReDim v(1 To UBound(cAry) + 1, 1 To UBound(cAry(0)))
For i = LBound(cAry) To UBound(cAry)
For ii = LBound(cAry(i)) To UBound(cAry(i))
v(i + 1, ii) = cAry(i)(ii)
Next
Next
Stop
'ターゲットシートのA列は残したいので仮シートに書き出して利用
Columns("A").Copy
Dim LST As Worksheet
Set LST = Sheets.Add(After:=Sheets(Sheets.Count))
LST.Name = "temp"
'仮シートに一時書き出し
Worksheets("temp").Range("A1").PasteSpecial (xlPasteValues)
'ターゲットシートは書き込みに備えて初期化 (クーリン)
ActiveSheet.UsedRange.Clear
Worksheets("temp").Columns("A").Copy
Cells(2).Resize(UBound(v, 1), UBound(v, 2)) = v
'ターゲットシートに書き戻す
Columns("A").PasteSpecial (xlPasteValues)
'仮シートは削除
Sheets("temp").Delete
Set LST = Nothing
End Sub
（コニャック） 2023/01/24(火) 14:24:53
cAryが縦分、temp← = →cAry(0))は横分の要素数です
次に以下は作成したジャグ配列[配列の配列＾＾；]をセルに一括書き込み
可能な 二次元配列[再定義したｖ]に書き込んでいます。
そのままでもApplication.Transeposeを使えば可能なのですが扱える要素
数に限界が[約3万？]が有るためこのような書き方が癖になっています。＾＾；。m(__)m
cAry(i)(ii)
表現は不適切かもしれませんが、エクセルの表みたいな感じで(￣▽￣)
cAryのi行目のii列という感じで扱えます。
cAryの最小要素数から最大要素数までループ
For i = LBound(cAry) To UBound(cAry)
cAry(i)の最小〜最大要素までループ
For ii = LBound(cAry(i)) To UBound(cAry(i))
cAryの要素カウンタiはゼロスタート、
vは１スタートなので
+1しています
iiも1スタートなのでそのままです
v(i + 1, ii) = cAry(i)(ii)
Next
Next
ActiveSheet.UsedRange.Clear
ｖの縦方向最大要素数と横最大要素数分セルを範囲指定後そちらに
ｖをほり込んでいます。
Cells(1).Resize(UBound(v, 1), UBound(v, 2)) = v
cAryに格納するtempの要素数をもう一つ拡張して、最初の要素に
元情報[A列]を処理時に、格納し、後は一毎にずらして、格納すれば
手間いらずかと。思います。
配列については
ジャグ配列
vba 一次元配列、二次元配列
等々でご検索賜れば、懇切丁寧な説明サイトが多数御座いますです。
m(__)m
（隠居Z） 2023/01/24(火) 16:03:25
■１
Dim sc As String
Dim scb As Byte
sc = InputBox("結合列の指定")
scb = Len(sc) '選択列の総数
とのことですが、提示された例でいうと、【sc】【scb】には、それぞれ何が入る想定なんでしょうか？
■２
「削除列は、可変で飛び飛びにある場合もあるので難しいです。」ということですから、そちらのパターンの例示もされた方がよいとおもいます
（B列から何列分という指定で済む話じゃなくなりますよね。）
なお、削除列とは言いつつ、実際に削除はしないですよね？実際には"氏名"だけ除外したいのではないでしょうか。
(ただし、エクセル君にとっては氏名と見分ける方法がないので、提示の内容状況だと自動処理は難しいと思います）
※ ↑を書いた後、「2023/01/24(火) 14:24:53」のコメントを拝見しました。
やはり"セルの削除"が絡んでくるのでしょうか？
■３
「■２」を踏まえた話になりますが、本当にセル削除するならば、１行ごとに対象セルを削除して左に詰めるだけで、望む結果が得られますよね。
Sub テスト環境生成()
Dim i As Long
Dim 配列 As Variant
With ThisWorkbook.Worksheets.Add
.Range("A4").Value = "4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知"
.Range("A5").Value = "5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸"
.Range("A6").Value = "6th-誰かのために走ります-竹之内和久-それが僕の目指すサッカーです-ふでやすかずゆき-えんどうてつや-北村友幸--"
For i = 4 To 6
配列 = Split(.Cells(i, "A").Value, "-")
.Cells(i, "B").Resize(, UBound(配列) + 1).Value = 配列
Next i
.Range("A4").CurrentRegion.EntireColumn.AutoFit
.Range("D4:G4,D5:G5,H6,D6").Interior.Color = vbRed
End With
End Sub
'================================
Sub 赤塗りつぶしセルを削除して左に詰める()
Dim 行 As Long, 列 As Long
Dim tmpRNG As Range
Stop 'ブレークポイントの代わり
With ActiveSheet
For 行 = 4 To 6
Set tmpRNG = Nothing
For 列 = 2 To .Cells(行, .Columns.Count).End(xlToLeft).Column
If .Cells(行, 列).Interior.Color = vbRed Then
If tmpRNG Is Nothing Then
Set tmpRNG = .Cells(行, 列)
Else
Set tmpRNG = Union(tmpRNG, .Cells(行, 列))
End If
End If
Next 列
If Not tmpRNG Is Nothing Then
tmpRNG.Delete Shift:=xlToLeft
End If
Next 行
End With
End Sub
（もこな２） 2023/01/24(火) 16:37:27
私は配列を使えない人なのでじっくり解説を勉強してみます。
その後、一番最初の不完全であった自分のコードを見直して
以下のように修正しました。
（一応、思う結果はでていると思います。）
不都合があればアドバイスおねがいします。
Sub 再結合()
Dim sc As String
Dim sm As String
Dim scb As Byte
Dim scby As Variant
'結合列を複数選択(形式: bce)
sc = StrConv(InputBox("結合列の指定"), vbNarrow)
scb = Len(sc) '選択列の総数
ReDim scby(scb)
'結合列の切り出し
Dim i As Long
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
'結合する文字を指定
Dim km As String
km = StrConv(InputBox("結合する文字を指定"), vbNarrow)
Dim ii As Long
Dim lc As Long
Dim lr As Long
Dim kmj As String
Dim temp As String
lc = Cells(Rows.Count, 1).End(xlUp).Row
lr = Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
'再結合した文字列を最終列の横に書き出す
For ii = 1 To lc
For i = 1 To scb
temp = Cells(ii, scby(i)) & km
kmj = kmj & temp
Next
kmj = Left(kmj, Len(kmj) - 1) '不要な最後の一文字削除
Cells(ii, lr + 1) = kmj
kmj = ""
Next
'不要列の削除
For i = 1 To scb
For ii = lr To 2 Step -1
'指定列だったら列削除
If ii <> Range(scby(i) & "1").Column Then
Columns(ii).Delete
End If
Next
Next
Application.ScreenUpdating = True
End Sub
（コニャック） 2023/01/24(火) 16:46:14
列、全部消えちゃわない？ A列から評価して順次削除していくと、列がずれるから思い通りの結果にならないと思うよ。 消す場合は行もそうだけど、お尻から頭で考えないとだめだと思う。 配列使わないで削除する場合は、こんな感じではどうですか？
Sub 再結合3()
Dim dlm As String
Dim joinC As Range
Dim ws As Worksheet
Dim r As Long '行のループ用
Dim lr As Long '最終行
Dim c As Long '列のループ
Dim v As Variant
Dim cnt As Long '列のカウント用
'//対話設定とエラー処理
dlm = InputBox("区切り文字を指定してください")
If Len(dlm) = 0 Then
MsgBox "区切り文字が指定されなかったため、処理を中断します"
Exit Sub
End If
Set joinC = Application.InputBox("結合したい列を選択してください。飛び飛びは、Ctrl押しながら選択してください。", Type:=8)
If joinC Is Nothing Then
MsgBox "列が選択されなかったため、処理を中断します。"
Exit Sub
End If
'//基本データの取得
Set ws = joinC(1).Parent
Set joinC = Intersect(ws.Rows(1), joinC.EntireColumn)
cnt = joinC.Count + 1
'//バックアップ作成
ws.Copy after:=Sheets(Sheets.Count)
'//列の削除
For c = ws.Range("A1", ws.UsedRange).Columns.Count To [b1].Column Step -1
If Intersect(joinC, ws.Cells(1, c)) Is Nothing Then
ws.Cells(1, c).EntireColumn.Delete
End If
Next c
'//文字の結合
For r = 1 To ws.Cells(Rows.Count, "A").End(xlUp).Row
v = ws.Cells(r, "B").Resize(, cnt - 1).Value
If IsArray(v) Then
v = Join(Application.Transpose(Application.Transpose(v)), dlm)
End If
ws.Cells(r, cnt + 1).Value = v
Next r
MsgBox "出力しました"
End Sub
（稲葉） 2023/01/24(火) 17:29:48
＞【sc】【scb】には、それぞれ何が入る想定なんでしょうか？
1.
sc - > 結合する列 BC と入力すれば、B列とC列を結合
scb -> 選択した列の総数 BCなら ２
2.飛び飛びにある場合のパーターンです（B,Dの場合）
B,Cの場合はたまたま氏名だけの除去のようになりましたが偶然です。
（整理前のパターンによってどの列を結合するかは決まっていません。）
セルの削除（選択列以外の列の削除）は必要です。
整理前
|[A] |[B]|[C] |[D] |[E] |[F] |[G] |[H]
[4]|4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知 |4th|命かけて僕は生きたいんです |浦畑達彦 |中村哲治 |久藤瞬 |吉田正幸、服部憲知|
[5]|5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸 |5th|だから僕はこれからも走るよ風間くん|水上清資 |境宗久 |牧田佳織 |松岡秀明、南東寿幸|
[6]|6th-誰かのために走ります-それが僕の目指すサッカーです-ふでやすかずゆき-竹之内和久-えんどうてつや-北村友幸--|6th|誰かのために走ります |それが僕の目指すサッカーです|ふでやすかずゆき|竹之内和久|えんどうてつや
整理後（BD列を結合してD列へ 生理前ののC,E,F,G,Hは削除）
|[A] |[B]|[C] |[D]
[4]|4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知 |4th|浦畑達彦 |4th-浦畑達彦
[5]|5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸 |5th|水上清資 |5th-水上清資
[6]|6th-誰かのために走ります-それが僕の目指すサッカーです-ふでやすかずゆき-竹之内和久-えんどうてつや-北村友幸--|6th|それが僕の目指すサッカーです|6th-それが僕の目指すサッカーです
３．列を指定して削除以外に
１行ごとに対象セルを削除して左に詰める方法でも、望む結果が得られると思います。
'============================================================================
ここまで、ずっと「BC」だけでテストしてきて
飛び飛びの例を試していなかったのに気が付きました。
私のコード(1/24 16:46:14)で試しに「BD」で試してみたら上手くいきません。
不要列の削除直前までは上手く
書き出せていますが不要行の削除が上手く処理できていません。
稲葉さんからお尻から処理するようにアドバイスを受けて下記のように変更しましたが
やはり思う結果が出ませんでした。
'不要列の削除
For i = scb To 1 Step -1
For ii = lr To 2 Step -1
'指定列だったら列削除
If ii <> Range(scby(i) & "1").Column Then
Columns(ii).Delete
End If
Next
Next
稲葉さんの「再結合３」ですが飛び飛びの例を試してみたら
列削除は完璧ですが、
以下のように結合文字をマイナス(-)にしても「bd」で結合されていました。
(bd は、結合すべき列）
整理後(BD列を結合してD列へ 整理前ののC,E,F,G,Hは削除)
|[A] |[B]|[C] |[D]
[3]|3rd-お前とサッカーするのはめちゃくちゃ楽しいぜバカ野郎-高屋敷英夫-二瓶勇一-えんどうてつや-北村友幸|3rd|高屋敷英夫|3rdbd高屋敷英夫
[4]|4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知 |4th|浦畑達彦 |4thbd浦畑達彦
[5]|5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸 |5th|水上清資 |5thbd水上清資
（コニャック） 2023/01/24(火) 19:20:37
＞以下のように結合文字をマイナス(-)にしても「bd」で結合されていました。 こっちで試すとちゃんといくんだけどねぇ・・・ 私の場合、最初に結合文字、次に列の指定だけど、設定あってる？ 「区切り文字を指定してください」 で 「-」 と入力 「結合したい列を選択してください。飛び飛びは、Ctrl押しながら選択してください。」 で、セルを選択すると、$B$1,$D$1あるいは$B:$B,$D:$D と表示されて、OK押すといいはずなんだけど。
|[A] |[B]|[C] |[D]
[1]|4th-命かけて僕は生きたいんです-浦畑達彦-中村哲治-久藤瞬-吉田正幸、服部憲知 |4th|浦畑達彦 |4th-浦畑達彦
[2]|5th-だから僕はこれからも走るよ風間くん-水上清資-境宗久-牧田佳織-松岡秀明、南東寿幸 |5th|水上清資 |5th-水上清資
[3]|6th-誰かのために走ります-それが僕の目指すサッカーです-ふでやすかずゆき-竹之内和久-えんどうてつや-北村友幸--|6th|それが僕の目指すサッカーです|6th-それが僕の目指すサッカーです
（稲葉） 2023/01/24(火) 19:57:35
excel 2016 ３６５タイプ
os Ｗｉｎ１０
でした。m(__)m
（隠居Z） 2023/01/24(火) 21:29:50
本日、早朝より頭を冷やしてチェック結果
稲葉さんのコードで上手く処理できていました。
（昨夜は、INPUTで間違いが有ったと思われます。）
再結合3()のコード試用中ですが、
結合したい列の選択でCANCELを押すと
「オブゼクトが必要です。」のエラーがでます。
＜改行するようにコード変更しています。＞
Set joinC = Application.InputBox("結合したい列を選択してください。" & vbCrLf & _
"飛び飛びは、Ctrl押しながら選択してください。", Type:=8)
If joinC Is Nothing Then
MsgBox "キャンセルが押された。" & vbCrLf & _
"又は列が選択されなかったため、処理を中断します。"
Exit Sub
End If
（区切り文字の指定では、CANCELでMSGBOXの後うまくマクロが終了します。）
（コニャック） 2023/01/25(水) 06:13:06
いらない列を削除するのではなく、必要な列のみ別シートにコピペして
元のシート削除後に書き戻すようにしました。
エラーチェックは、後で検討する予定なのでコードには反映されていません。
Sub 再結合()
Dim sc As String
Dim sm As String
Dim scb As Byte
Dim scby As Variant
'結合列を複数選択(形式: bce)
sc = StrConv(InputBox("結合列の指定"), vbNarrow)
scb = Len(sc) '選択列の総数
ReDim scby(1 To scb)
'結合列の切り出し
Dim i As Long
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
'結合する文字を指定
Dim km As String
km = StrConv(InputBox("結合する文字を指定"), vbNarrow)
Dim ii As Long
Dim lc As Long
Dim lr As Long
Dim kmj As String
Dim temp As String
lc = Cells(Rows.Count, 1).End(xlUp).Row
lr = Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
'再結合した文字列を最終列の横に書き出す
For ii = 1 To lc
For i = 1 To scb
temp = Cells(ii, scby(i)) & km
kmj = kmj & temp
Next
kmj = Left(kmj, Len(kmj) - 1) '不要な最後の一文字削除
Cells(ii, lr + 1) = kmj
kmj = ""
Next
'残す列だけ仮シートに書き出して利用
Dim LST As Worksheet
Set LST = Sheets.Add(after:=Sheets(Sheets.Count))
LST.Name = "temp"
'仮シートに一時書き出し
Worksheets("Sheet1").Columns("A").Copy
Worksheets("temp").Range("A1").PasteSpecial (xlPasteValues)
For i = 1 To scb
Worksheets("Sheet1").Columns(scby(i)).Copy
Worksheets("temp").Columns(i + 1).PasteSpecial (xlPasteValues)
Next
Worksheets("Sheet1").Columns(lr + 1).Copy
Worksheets("temp").Columns(scb + 2).PasteSpecial (xlPasteValues)
'ターゲットシートは書き込みに備えて初期化 (クーリン)
Worksheets("Sheet1").UsedRange.Clear
'書き出しを元のシートにコピペ
Worksheets("temp").Range("A:E").Copy Sheets("Sheet1").Range("A1")
'仮シートは削除
Sheets("temp").Delete
Set LST = Nothing
Application.ScreenUpdating = True
End Sub
（コニャック） 2023/01/25(水) 06:59:44
エラーのところ、すみません、こちらのミスです。
Onerrorで対応します。
On Error Resume Next
Set joinC = Application.InputBox("結合したい列を選択してください。飛び飛びは、Ctrl押しながら選択してください。", Type:=8)
On Error GoTo 0
試したところ、
＞'書き出しを元のシートにコピペ
＞Worksheets("temp").Range("A:E").Copy Sheets("Sheet1").Range("A1")
これだと、A:E列固定になるので、2列より列数が増えたとき対応できないんじゃないですか？
他のコードの中身ですが、以下のところ直すともっと見やすくなるんじゃないかと思います。 検討してください。
＞Set LST = Sheets.Add(after:=Sheets(Sheets.Count))
せっかく変数のワークシートオブジェクト入れてるのに、以降全部Worksheet("temp")じゃないですか。
＞Worksheets("temp").Range("A1").PasteSpecial (xlPasteValues)
LST.Range("A1").PasteSpecial (xlPasteValues)
のほうがいいんじゃないですか？
Worksheet("Sheet1")も多量に出てくるので、変数に入れてあげたほうがいいと思いますよ。
＞'再結合した文字列を最終列の横に書き出す ＞ temp = Cells(ii, scby(i)) & km この部分も、Sheet補ってあげたほうがいいんじゃないですか？ 統一性がないです。
（稲葉） 2023/01/25(水) 09:52:37
On Error Resume Next / Goto 0 でエラー処理できました。
「set joint」でキャンセルを押すとエラーが出るのでエラーを無視して
次のキャンセルでエラートラップを拾えるようにするテクニックですね。
＞'書き出しを元のシートにコピペ
＞Worksheets("temp").Range("A:E").Copy Sheets("Sheet1").Range("A1")
＞これだと、A:E列固定になるので、2列より列数が増えたとき対応できないんじゃないですか？
おっしゃるとうりです。
ちゃんと最大列番号をチェックして書き戻すように処理を変更します。
＞Set LST = Sheets.Add(after:=Sheets(Sheets.Count))
＞せっかく変数のワークシートオブジェクト入れてるのに、以降全部Worksheet("temp")じゃないですか。
単に最後にシートを追加する意味でLST(LastSheet）をセットしたのですが
そのままワークシートの指定に使えるのを知りませんでした。
activesheetでマクロを走らす事を想定していましたが
ターゲットのシートを明確にしたほうが問題が起きなそうなので
その他、アドバイスを受けた点も含めてコードを見直しています。
これで完成に近づいたと思いますが
まだ変なところあればアドバイスお願いします。
Sub 再結合1()
Dim sc As String
Dim sm As String
Dim scb As Byte
Dim scby As Variant
Dim TST As Worksheet
Set TST = Worksheets("Turget")
'結合する列を複数選択(形式: bce で一度に指定)
sc = StrConv(InputBox("結合する列の指定"), vbNarrow) '全角、半角 どちらでもOK）
scb = Len(sc) '選択列の総数
If scb = 0 Then
MsgBox "キャンセルが押された。" & vbCrLf & _
"又は結合する列が指定されなかったため、処理を中断します"
Exit Sub
End If
ReDim scby(1 To scb)
'結合列は、? (bce -> b,c,e と単独に切り分ける）
Dim i As Long
For i = 1 To scb
scby(i) = Mid(sc, i, 1)
Next
'列を結合するのに間に挟む文字を指定
Dim km As String
km = StrConv(InputBox("結合する文字列を指定"), vbNarrow) '全角、半角 どちらでもOK）
If Len(km) = 0 Then
MsgBox "キャンセルが押された。" & vbCrLf & _
"又は結合文字列が指定されなかったため、処理を中断します"
Exit Sub
End If
Dim ii As Long
Dim lc As Long
Dim lr As Long
Dim kmj As String
Dim temp As String
lc = TST.Cells(Rows.Count, 1).End(xlUp).Row '処理行数
lr = TST.Cells(1, Columns.Count).End(xlToLeft).Column '一番右側の列 (最大使用列数)
Application.ScreenUpdating = False
'再結合した文字列を最終列の横に書き出す
For ii = 1 To lc
For i = 1 To scb
temp = TST.Cells(ii, scby(i)) & km
kmj = kmj & temp
Next
kmj = Left(kmj, Len(kmj) - Len(km)) 'Len(km) --> 最後に不要な結合文字列が付加されるので削除
TST.Cells(ii, lr + 1) = kmj
kmj = ""
Next
'仮シートを作成して残す列だけを書き出して利用
Dim LST As Worksheet
Set LST = Sheets.Add(after:=Sheets(Sheets.Count))
LST.Name = "temp"
'仮シートに一時書き出し（A列＋連結指定列＋連結した文字列)
TST.Columns("A").Copy
LST.Range("A1").PasteSpecial (xlPasteValues) 'A列のみ書き出し
For i = 1 To scb '連結列の書き出し
TST.Columns(scby(i)).Copy
LST.Columns(i + 1).PasteSpecial (xlPasteValues)
Next
TST.Columns(lr + 1).Copy
LST.Columns(scb + 2).PasteSpecial (xlPasteValues) '連結した列の書き出し
'ターゲットシートは書き込みに備えて初期化 (クーリン)
TST.UsedRange.Clear
'書き出しを元のシートにコピペ
Dim LSTMC As Long
LSTMC = LST.Cells(1, Columns.Count).End(xlToLeft).Column
LST.Range(Cells(1, "A"), Cells(lc, LSTMC)).Copy TST.Range("A1")
'仮シートは削除(確認メッセージをオフにする)
Application.DisplayAlerts = False
Sheets("temp").Delete
Application.DisplayAlerts = True
Set LST = Nothing
Application.ScreenUpdating = True
TST.Activate
End Sub
（コニャック） 2023/01/25(水) 12:01:01
＞LST.Range(Cells(1, "A"), Cells(lc, LSTMC)).Copy TST.Range("A1")
この部分
LST.Range(LST.Cells(1, "A"), LST.Cells(lc, LSTMC)).Copy TST.Range("A1")
Rangeの中身のCellにシート指定しないと、アクティブシートがLSTと異なった場合エラー出ます。
＞Sheets("temp").Delete
ここがなおってないです。
＞Set TST = Worksheets("Turget")
ここは突っ込むところではないかもしれないですが、Targetですかね？
あとはどこまで突き詰めるかだと思いますが ＞ For ii = 1 To lc '★ここはlrじゃないかな？ ＞ For i = 1 To scb ＞ temp = TST.Cells(ii, scby(i)) & km '★このループ処理だと、BDなら問題ないけど、DBと入力されたら逆転しないかな？ ＞ kmj = kmj & temp ＞ Next ＞ kmj = Left(kmj, Len(kmj) - Len(km)) 'Len(km) --> 最後に不要な結合文字列が付加されるので削除 ＞ TST.Cells(ii, lr + 1) = kmj ＞ kmj = "" ＞ Next
（稲葉） 2023/01/25(水) 12:50:13
複数のオブゼクト(LST)を書き忘れているところや統一されていない箇所がありました。
修正します。
＞ For ii = 1 To lc '★ここはlrじゃないかな？
lcにしないと書き出しが列数だけで終わってしまいますので
総行数のlcで良いと思います。
＞temp = TST.Cells(ii, scby(i)) & km '★このループ処理だと、BDなら問題ないけど、DBと入力されたら逆転しないかな？
DBで試してみましたが、逆転せずに出力されました。
まだまだチェックが甘く見直しが必要な箇所が出てきそうが
一応自前のコードは、完成と言う事にして
アドバイス頂いた回答者さんのコードを勉強したいと思います。
本当に配列を使い慣れていないので理解が進みません。
（配列を使う代わりに仮シートや仮セルを利用する事が多いのが現状です）
（コニャック） 2023/01/25(水) 13:26:07
変数がlc = LastColumnじゃなくて、LastRowなのね・・・
＞DBで試してみましたが、逆転せずに出力されました。
これほんとに？
このテストデータでやったら、
|[A] |[B]|[C]|[D]|[E]|[F]|[G]|[H]|[I]|[J]|[K]
[1]|TEST|B |C |D |E |F |G |H |I |J |K
[2]|TEST|B |C |D |E |F |G |H |I |J |K
[3]|TEST|B |C |D |E |F |G |H |I |J |K
こうなったよ？
|[A] |[B]|[C]|[D]
[1]|TEST|D |B |D-B
[2]|TEST|D |B |D-B
[3]|TEST|D |B |D-B
（稲葉） 2023/01/25(水) 15:43:03
＞DBで試してみましたが、逆転せずに出力されました。
「逆転」の意味の認識が違っていました。
提示いただいたシートレイアウトで説明すると
私の認識では、最後に出力されるD-BがB-Dと逆になるのでは無いかとのご指摘だと思ったのですが
稲葉さんは、B列がDでC列がBと逆になるとの指摘だったのですね。
個人的には、列が逆に成っても問題ありません。
最終的に欲しいのは、B-Dで途中の列は、順番(Dの次はC）の参考で十分と考えています。
＞変数がlc = LastColumnじゃなくて、LastRowなのね・・・
変数が変な具合で混乱させてすいません。
こちらも訂正するようにします。
（コニャック） 2023/01/25(水) 17:08:04
なんどもごめんなさい。 言葉じゃわからなかったので、これでいいのかだけ教えてください。
1行目は稲葉のコード、
2行目がコニャックさんのコードの結果です。
いずれも、D,Bの順番に指定しています。
|[A] |[B] |[C] |[D] |[E]
[1]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|2nd |岡田達也|2nd-岡田達也|稲葉
[2]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|岡田達也|2nd |岡田達也-2nd|コニャックさん
元データ
|[A] |[B]|[C] |[D] |[E] |[F] |[G]
[1]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|2nd|夢の一員になりたい|岡田達也|黒田晃一郎|川島尚|高澤美佳
（稲葉） 2023/01/25(水) 17:29:40
D,B（DB)の順番に指定した場合
私が欲しいのは、以下になります。
2]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|岡田達也|2nd |岡田達也-2nd
最終列の出力は、Dの次は、結合文字（文字列）を挟んでBが出力です。
間にある列の順番も、Dの次がBになります。
（コニャック） 2023/01/25(水) 18:36:14
ということは、私の回答は端から期待外れってことですね。 納得できました。ありがとうございます。 （稲葉） 2023/01/25(水) 18:45:51
>以下のようにしたい >[1]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|2nd|夢の一員になりたい|2nd-夢の一員になりたい| >私が欲しいのは、以下になります。 >2]|2nd-夢の一員になりたい-岡田達也-黒田晃一郎-川島尚-高澤美佳|岡田達也|2nd |岡田達也-2nd 条件変わったの? （konnnyaku） 2023/01/25(水) 19:09:43
条件を変えた認識は有りませんが、説明が至らず右往左往してしまいました。
至らぬ点を含めてお詫びいたします。
それでも何とか皆様のお陰様でコードが完成しました。
改めてお礼申し上げます。
（コニャック） 2023/01/26(木) 06:43:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.