Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(指定なし : 指定なし)
A列に合わせて、B列の改行を一つにまとめたい
投稿日時: 18/03/02 16:34:20
投稿者: n_sugi8821

+−−−+−−−+ーーー+
|   | A | B |
+−−−+ーーー+−−−+
| 1 + あ | Q |
+−−−+ーーー+−−−+
| 2 |   |  か |
+−−−+ーーー+−−−+
| 3 |   |  だ |
+−−−+ーーー+−−−+
| 4 |   |  じ |
+−−−+ーーー+−−−+
| 5 |   |  K |
+−−−+ーーー+−−−+
| 6 |   |  4 |
+−−−+ーーー+−−−+
| 7 | か | Q |
+−−−+ーーー+−−−+
| 8 | さ | V |
+−−−+ーーー+−−−+
| 9 |   |   |
+−−−+ーーー+−−−+
| 10 |   | R |
+−−−+ーーー+−−−+
| 11 |   | R |
+−−−+ーーー+−−−+
  
となっているものを、
+−−−+−−−+ーーー+
|   | A | B |
+−−−+ーーー+−−−+
| 1 + あ | Q |
+   +ーーー+   +
|   |   |  か |
+   +ーーー+   +
|   |   |  だ |
+   +ーーー+    +
|   |   |  じ |
+   +ーーー+    +
|   |   |  K |
+   +ーーー+    +
|   |   |  4 |
+−−−+ーーー+−−−+
| 2 | か | Q |
+−−−+ーーー+−−−+
| 3 | さ | V |
+   +ーーー+   +
|   |   |   |
+   +ーーー+   +
|   |   | R |
+   +ーーー+   +
|   |   | R |
+−−−+ーーー+−−−+
という風に、B列をセル内改行して、1行として扱いたいのですが、どのようにしてVBAを作ればよいのでしょうか?ご指南お願い致します。

回答
投稿日時: 18/03/02 17:06:28
投稿者: simple

詰まっているのは具体的にどのあたりですか?教えて下さい.
繰り返し処理とか、文字列の連結とか、vbLFが改行コードとかはわかりますか?
できているところまで示してみては?

回答
投稿日時: 18/03/09 14:49:01
投稿者: hatch315
メールを送信

こんな感じ
 
Public Sub test()
 
       Dim I As Long
       Dim J As Long
       Dim K As Long
       Dim Blankjudge As Integer
       Dim GroupIndicate As String
       Dim Startposition As Long
       Dim Msg As String
        
       I = 1
       K = 0
       Blankjudge = 0
       GroupIndicate = ActiveSheet.Range("A1")
       Startposition = 1
       ActiveSheet.Range("D:E") = ""
        
       Do Until I > 1048576 Or Blankjudge > 1
        
          If ActiveSheet.Range("B" & I) = "" Then
             Blankjudge = Blankjudge + 1
          Else
             Blankjudge = 0
          End If
           
          If ActiveSheet.Range("A" & I) <> "" And _
             GroupIndicate <> ActiveSheet.Range("A" & I) Then
           
             Msg = ""
             For J = Startposition To I - 1
              
                 If ActiveSheet.Range("B" & J) <> "" Then
                    Msg = Msg & ActiveSheet.Range("B" & J) & vbCrLf
                 Else
                    Msg = Msg & " " & vbCrLf
                 End If
             Next J
              
             K = K + 1
             ActiveSheet.Range("D" & K) = ActiveSheet.Range("A" & Startposition)
             ActiveSheet.Range("E" & K) = Left(Msg, Len(Msg) - 1)
              
             Startposition = I
          End If
           
          I = I + 1
       Loop
           
       Msg = ""
       For J = Startposition To I - 3
              
           If ActiveSheet.Range("B" & J) <> "" Then
              Msg = Msg & ActiveSheet.Range("B" & J) & vbCrLf
           Else
              Msg = Msg & " " & vbCrLf
           End If
       Next J
              
       K = K + 1
       ActiveSheet.Range("D" & K) = ActiveSheet.Range("A" & Startposition)
       ActiveSheet.Range("E" & K) = Left(Msg, Len(Msg) - 1)
End Sub

回答
投稿日時: 18/03/09 15:43:17
投稿者: 隠居じーさん

こんにちは ^^ 作ってみましたので。
 
Option Explicit
'**********************************************************
Sub main()
    Dim sh01 As Worksheet, sh02 As Worksheet
    Dim lr As Long, cnt As Long, rr As Range, r As Range, tmp
    Set sh01 = ThisWorkbook.Worksheets("Sheet1")
    sh01.Copy
    ActiveSheet.Name = Format(Now, "yymmdd-hhmmss")
    Set sh02 = ActiveSheet
    With sh02
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set rr = .Range("B1:B" & lr)
        rr(lr + 1, 0) = "dum"
        Application.DisplayAlerts = False
        For Each r In rr
            cnt = cnt + 1
            tmp = tmp & r & vbCrLf
            If r(2, 0) <> "" Then
                tmp = Mid(tmp, 1, Len(tmp) - 2)
                Range(rr(r.Row - cnt + 1, 1), rr(r.Row, 1)).Merge
                rr(r.Row - cnt + 1, 1) = tmp
                tmp = ""
                cnt = 0
            End If
        Next
    Application.DisplayAlerts = True
    End With
    rr(lr + 1, 0) = ""
    Set rr = Nothing
    Set sh02 = Nothing
    Set sh01 = Nothing
End Sub

回答
投稿日時: 18/03/09 16:48:28
投稿者: 隠居じーさん

^^;
プロシジャー名から17行目
tmp = Mid(tmp, 1, Len(tmp) - 2)  を
 
tmp = Left(tmp, Len(tmp) - 2)
に差し換えしてください。
 
m(__)m
 

回答
投稿日時: 18/03/10 12:05:37
投稿者: もこな2

確認ですが、元データのB9セルはブランクですか?
 
また、提示のコードを解析するのも大変なので、具体的にどこで詰まってるのかも教えてください。
(とりあえず、コンパイルエラーにはならないみたいですが)

回答
投稿日時: 18/03/12 15:09:07
投稿者: もこな2

あぁ・・・今気づきました。
「n_sugi8821」さんと「hatch315」さんは別人なんですね。
 
 18/03/10 12:05:37の「また、〜」以降のくだりは無視してください。

回答
投稿日時: 18/03/13 11:03:10
投稿者: mattuwan44

処理の流れとしたら、
 
0)キーとなるセルのアドレスの初期値の取得
1)B列を上から順に繰り返し見て行く
2)もしキーが変わったら
真の時)記憶したアドレスから、今見ている1個上までの文字を繋いで出力し
    キーとなるセルの位置を記憶しなおす
3)次のセルを見る
 
となると思います。
 
sub test()
   dim rng as range
   dim c as range
   dim rngKey as range
   dim ixRow as long
 
   set rngKey = range("A1")
   set rng = range(range("B1"),cells(rows.count,"B").end(xlup).offset(1))
   For each c in rng
      if rngkey.value <> c.offset(0,-1).value then
         ixrow=ixrow + 1
         cells(ixrow,3).value=rngkey.offset(0,-1).value
         cells(ixrow,4).value=join(worksheetfunction.Transpose(range(rngkey,c.offset(-1,0)).value),vblf)
    set rngkey = c
   next
end sub
 
変数の使い方が肝になりますかね。

回答
投稿日時: 18/03/13 21:30:23
投稿者: simple

質問者が反応なく残念です。
折角なので私の書いたコードを参考までに載せます。
 
A列にキーが現れたら、その前の行までの領域を結合し、連結文字列を書き込む、
というのが処理の基本です。
 
ただし、以下のように、最初と最後が特別ですからそのための配慮が必要です。
・最初は、キーが現れるが、前の領域の処理は必要ない。(単に連結文字のセットだけ。)
・最後は、キーが現れないが、処理を追加して終了させる必要がある。
 
セルの結合と、文字列のセットは、2回書かずに、functionにしています。
 
参考にしてください。
 

Sub test()
    Dim start As Long
    Dim k     As Long
    Dim s1    As String
    Dim s2    As String
    Dim concat  As String 'concatenated
    
    start = 1
    For k = 1 To Cells(Rows.Count, 2).End(xlUp).Row
        s1 = Cells(k, 1).Value
        s2 = Cells(k, 2).Value
        If s1 <> "" Then
            If k = 1 Then       ' 特別処理(1)
                concat = s2
            Else
                Call myMerge(start, k - 1, concat)
                start = k
                concat = s2
            End If
        Else
            concat = concat & vbLf & s2
        End If
    Next
    Call myMerge(start, k - 1, concat) ' 特別処理(2)
End Sub

'concat を書き込む(k1行から k2行まで連結し、concat をセット)
Function myMerge(k1 As Long, k2 As Long, concat As String)
    Application.DisplayAlerts = False
    Range(Cells(k1, 2), Cells(k2, 2)).Merge
    Application.DisplayAlerts = True
    Cells(k1, 2).Value = concat
End Function

一応お題なので、コードを書いてはみたものの、
そもそもこれは何の効果がある作業なんだろうか。
見た目はほぼ同じなのに、構造が複雑になるだけ。
後続の処理があるなら、きっと結合セルに手を焼くことになる。
本来なら、こうしたことはしないほうがよいだろうと思う。

回答
投稿日時: 18/03/14 14:09:28
投稿者: Suzu

横やりですみません。
 

simple さんの引用:
そもそもこれは何の効果がある作業なんだろうか。
見た目はほぼ同じなのに、構造が複雑になるだけ。
後続の処理があるなら、きっと結合セルに手を焼くことになる。

 
同様に、疑問には思ったので積極的に考えてはいなかったのですが、
あれ・・と思ったので。
 
きっと結合セルに手を焼く
 
質問者さんからのレスがあれば、はっきりするのでしょうが
 
+−−−+−−−+ーーー+
|   | A | B |
+−−−+ーーー+−−−+
| 1 + あ | Q |
+   +ーーー+   +
|   |   |  か |
+   +ーーー+   +
|   |   |  だ |
+   +ーーー+    +
|   |   |  じ |
+   +ーーー+    +
|   |   |  K |
+   +ーーー+    +
|   |   |  4 |
+−−−+ーーー+−−−+
 
これ、左の「1」というのは、Excelの行列番号の「1」なんではないでしょうか。
A列に、罫線が入っていて判りづらいですが。 B1のセルに1文字づつ改行を入れる。。
と認識していました。
 
なので、セル結合は無いのではないかな。と言う推測です。
 
n_sugi8821 さん どうなのでしょうか。

トピックに返信