ここから本文です

VBAで文字連結を写真のようにしたいです。

kk5********さん

2019/10/1818:10:21

VBAで文字連結を写真のようにしたいです。

分かりづらいと思いますがよろしくお願いしますm(__)m

Set myDic,rr.Offset,End With,Set rr,CreateObject,With rr.Resize,文字連結

閲覧数:
67
回答数:
2

違反報告

ベストアンサーに選ばれた回答

30246kikuさん

2019/10/2211:28:52

以下でどうなりますか


やっていることは

A1 ~ A 最終行の範囲で 6 列分入手します
5 列目は不要になるので、
1 行目(項目行)の 6 列目 → 5 列目に設定し直して、
2 行目から、A 列(1 列目)の値を見ながら上に詰め直し
A 列(1 列目)の値が連続する間、
6 列目の値を、詰め直した 5 列目に追加
最終的に、詰め直した分を書き出して・・・

よって、
・A 列の値が連続した単位で上に詰め直す
・その中で、6 列目に重複あっても、無条件で追加

の動作となってます

A 列の値は連続していない場合がある・・・とか
6 列目に重複があり、重複を排除したい・・・とかあれば、
記述の変更が必要になりますが、そんなに難しい事ではない

この方法が理解できれば、1つ前の御質問にも応用できるかと・・・

どうなりますか

※ 値だけを処理しているので、
後は見栄え(罫線、配置、背景色)等は組み込んでみてください


Option Explicit

Public Sub Samp1()
   Dim vA As Variant
   Dim i As Long, j As Long, k As Long

   With ActiveSheet
      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
         vA = .Resize(, 6).Value
      End With

      k = 1
      vA(k, 5) = vA(k, 6)
      i = 2
      While (i <= UBound(vA))
         k = k + 1
         For j = 1 To 4
            vA(k, j) = vA(i, j)
         Next
         vA(k, 5) = vA(i, 6)
         For i = i + 1 To UBound(vA)
            If (vA(i, 1) <> vA(k, 1)) Then Exit For
            vA(k, 5) = vA(k, 5) & "、" & vA(i, 6)
         Next
      Wend

      Application.ScreenUpdating = False
      With .Range("H1").Resize(k, 5)
         .EntireColumn.ClearContents
         .Value = vA
      End With
      Application.ScreenUpdating = True
   End With
End Sub

質問した人からのコメント

2019/10/23 10:55:35

ありがとうございます
異常なくできました!

ベストアンサー以外の回答

1〜1件/1件中

2019/10/1820:09:46

画像の通り(正し罫線など装飾はなし)の配置で纏める事のみ書きました。
罫線等はマクロの自動記録ででもいけるでしょ。

Sub megu()
Dim myDic As Object
Dim myAry As Object
Dim r As Range, rr As Range
Dim key, v, st As String

Set myDic = CreateObject("Scripting.Dictionary")

For Each r In Range("A2", Cells(Rows.Count, 1).End(xlUp))
st = Join(Application.Index(r.Resize(, 5).Value, 1, 0), "_")
If Not myDic.Exists(st) Then myDic.Add st, CreateObject("System.Collections.ArrayList")
myDic(st).Add (r.Offset(, 5).Value)
Next

Set rr = Range("H2")

For Each key In myDic.Keys
v = Split(key, "_")
With rr.Resize(, 5)
.Value = v
.Value = .Value
End With
rr.Offset(, 5).Value = Join(myDic(key).ToArray(), ",")
Set rr = rr.Offset(1)
Next

Set myDic = Nothing
Set rr = Nothing
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる