Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7038 / 13644 ツリー ←次へ | 前へ→

【41582】縦セル内の文字を合成したいのです。 くじら 06/8/14(月) 23:18 質問[未読]
【41584】Re:縦セル内の文字を合成したいのです。 かみちゃん 06/8/14(月) 23:50 発言[未読]
【41590】Re:縦セル内の文字を合成したいのです。 くじら 06/8/15(火) 9:03 回答[未読]
【41587】Re:縦セル内の文字を合成したいのです。 ponpon 06/8/15(火) 0:34 発言[未読]
【41591】Re:縦セル内の文字を合成したいのです。 くじら 06/8/15(火) 9:22 回答[未読]
【41593】Re:縦セル内の文字を合成したいのです。 へっぽこ 06/8/15(火) 12:18 発言[未読]
【41595】Re:縦セル内の文字を合成したいのです。 くじら 06/8/15(火) 13:57 お礼[未読]
【41592】Re:縦セル内の文字を合成したいのです。 Hirofumi 06/8/15(火) 12:11 回答[未読]
【41594】Re:縦セル内の文字を合成したいのです。 Hirofumi 06/8/15(火) 13:11 回答[未読]
【41596】Re:縦セル内の文字を合成したいのです。 くじら 06/8/15(火) 13:59 お礼[未読]

【41582】縦セル内の文字を合成したいのです。
質問  くじら E-MAIL  - 06/8/14(月) 23:18 -

引用なし
パスワード
   くじらと申します。お世話になっています。
難問をクリアしたいので、アドバイスをお願いいたします。

【ご質問】
 セルB列には住所、セルC列にはビルが入力されています。
 B1:A市 B2:B市 B3:C市、C列は全て同じDビル
 これを、Eセル内に A市・B市・C市 というようにしたいのです。
 尚、同一ビルの場合に限り、上記のようにするので、C列=同じであれば。。
 というマクロになると思います。
 先日、ExcelVBA大辞典を購入しましたが、まだまだ勉強不足です。
 以上、宜しくお願い申し上げます。
  
 

【41584】Re:縦セル内の文字を合成したいのです。
発言  かみちゃん  - 06/8/14(月) 23:50 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> セルB列には住所、セルC列にはビルが入力されています。
> B1:A市 B2:B市 B3:C市、C列は全て同じDビル
> これを、Eセル内に A市・B市・C市 というようにしたいのです。
> 尚、同一ビルの場合に限り、上記のようにするので、C列=同じであれば。。

ご質問の趣旨がよくわかりません。
  A   B   C   D   E
1    A市 Dビル
2    B市 Dビル
3    C市 Dビル

       ↓

  A   B   C   D   E
1    A市 Dビル   A市
2    B市 Dビル   B市
3    C市 Dビル   C市

ということなのですか?

【41587】Re:縦セル内の文字を合成したいのです。
発言  ponpon  - 06/8/15(火) 0:34 -

引用なし
パスワード
   こういうことですか?

  A  B  C  D  E  F
1   A市 Dビル   Dビル A市,B市,C市,
2   B市 Dビル   Gビル D市,E市,F市,G市,
3   C市 Dビル   Tビル H市,I市,
4   D市 Gビル   Qビル J市,K市,L市,M市,N市,
5   E市 Gビル            
6   F市 Gビル            
7   G市 Gビル            
8   H市 Tビル            
9   I市 Tビル            
10  J市 Qビル            
11  K市 Qビル            
12  L市 Qビル            
13  M市 Qビル            
14  N市 Qビル            

Sub test()
  Dim myDic As Object
  Dim myR As Range, r As Range
  
  Set myDic = CreateObject("Scripting.Dictionary")
  Set myR = Range("C1", Range("C65536").End(xlUp))
  For Each r In myR
     myDic(r.Value) = myDic(r.Value) & r.Offset(, -1).Value & ","
  Next
  Range("E1").Resize(myDic.Count).Value = Application.Transpose(myDic.Keys)
  Range("F1").Resize(myDic.Count).Value = Application.Transpose(myDic.Items)
  
End Sub

【41590】Re:縦セル内の文字を合成したいのです。
回答  くじら E-MAIL  - 06/8/15(火) 9:03 -

引用なし
パスワード
   くじらです。

E1セル内に、A市・B市・C市 です。
E2、E3もE1と同じでもいいんです。
重複は削除すればいいので。

早速のご返答感謝しております。

ありがとうございます。

【41591】Re:縦セル内の文字を合成したいのです。
回答  くじら E-MAIL  - 06/8/15(火) 9:22 -

引用なし
パスワード
   くじらです。
ご返答ありがとうございます。感謝です!


>  A  B  C  D  E         F
>1   A市 Dビル   A市・B市・C市    Dビル
>2   B市 Dビル   A市・B市・C市    Dビル
>3   C市 Dビル   A市・B市・C市    Dビル
>4   D市 Gビル   D市・E市・F市    Gビル
>5   E市 Gビル   D市・E市・F市    Gビル         
>6   F市 Gビル   D市・E市・F市    Gビル         
>7   G市 Gビル   D市・E市・F市    Gビル         
>8   H市 Tビル   H市         Tビル         
>9   I市 Uビル   I市         Uビル         
>10   J市 Qビル   J市・K市       Qビル         
>11   K市 Qビル   J市・K市       Qビル           
>12   L市 Xビル   L市         Xビル 
>13   M市 Yビル   M市         Yビル            
>14   N市 Zビル   N市         Zビル            

です。

ビルが同じであれば、市を合成する。最後に、Eの重複行を削除すればいいですよね。問題は、1ビルのみがあるので、全て合成しないということです。難問です。

【41592】Re:縦セル内の文字を合成したいのです。
回答  Hirofumi  - 06/8/15(火) 12:11 -

引用なし
パスワード
   こんなかな?

'データは、A列〜E列の4列とし、転記するグループは、C列に有るとします
'実行時にC列で整列され終了直前に元の行位置に再整列されます

Option Explicit

Public Sub Sample()

  '元々のデータ列数(B列〜E列)
  Const clngColumns As Long = 4
  'グループの有る列(基準列B列からのC列の列Offset)
  Const clngGroup As Long = 1
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim vntResult As Variant
  Dim vntGroup As Variant
  Dim vntItems As Variant
  Dim strProm As String

  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = ActiveSheet.Cells(1, "B")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row + 1
    If lngRows <= 0 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データをC列で整列
    DataSort .Resize(lngRows, clngColumns + 1), .Offset(, clngGroup)
    'C列データを配列に取得
    vntGroup = .Offset(, clngGroup).Resize(lngRows + 1).Value
    'B列データを配列に取得
    vntItems = .Resize(lngRows + 1).Value
  End With
  
  '注目値の位置を記録
  lngTop = 1
  'データ行数のカウント初期値
  lngCount = 1
  '結果用変数に初期値代入
  vntResult = vntItems(1, 1)
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      'データを転記
      rngList.Offset(lngTop - 1, clngColumns - 2) _
            .Resize(lngCount).Value = vntResult
      '結果用変数に初期値代入
      vntResult = vntItems(i, 1)
      '注目値の位置を記録
      lngTop = i
      'データ行数のカウント初期値に
      lngCount = 1
    Else
      '結果用変数に「・」を挟んで追加
      vntResult = vntResult & "・" & vntItems(i, 1)
      'データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i

  With rngList
    '元データを復帰
    DataSort .Resize(lngRows, clngColumns + 1), .Offset(1, clngColumns)
    '復帰用Key列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
   
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

【41593】Re:縦セル内の文字を合成したいのです。
発言  へっぽこ  - 06/8/15(火) 12:18 -

引用なし
パスワード
   こんにちは。

私もひとつ作ってみました。

Sub サンプル1()
  Dim 開始行 As Long
  Dim 最終行 As Long
  Dim 上端行 As Long
  Dim 下端行 As Long
  Dim ビル名 As String
  Dim 市名合成 As String
  Dim i As Long

  上端行 = 1
  最終行 = Range("B65536").End(xlUp).Row
  Do
    ビル名 = Cells(上端行, "C").Value
    '同じビル名がどこまで続くか調べる。
    '(ワークシート関数MATCHとか逆検索とか出来そうだけどベタに探す)
    下端行 = 上端行
    Do
      下端行 = 下端行 + 1
    Loop Until (Cells(下端行, "C").Value <> ビル名) Or (下端行 > 最終行)
    下端行 = 下端行 - 1
    '上で求めた範囲の市名を合成する。
    For i = 上端行 To 下端行
      If i = 上端行 Then
        市名合成 = Cells(i, "B").Value '最初の行はカンマはいらない
      Else
        市名合成 = 市名合成 & "," & Cells(i, "B").Value
      End If
    Next
    '上で求めた範囲にビル名、市名を設定する。
    For i = 上端行 To 下端行
      Cells(i, "E").Value = 市名合成
      Cells(i, "F").Value = ビル名
    Next
    '次のビルの処理をする。
    上端行 = 下端行 + 1
  Loop Until 上端行 > 最終行
  MsgBox "おしまい"
End Sub

超ベタな方法なので行が多いと時間が掛かると思います。

【41594】Re:縦セル内の文字を合成したいのです。
回答  Hirofumi  - 06/8/15(火) 13:11 -

引用なし
パスワード
   結果の出力位置を間違えた様で?
以下を修正して下さい

      'データを転記
'      rngList.Offset(lngTop - 1, clngColumns - 2) _
            .Resize(lngCount).Value = vntResult
      'データを転記
      rngList.Offset(lngTop - 1, clngColumns - 1) _
            .Resize(lngCount).Value = vntResult '★変更

また、削除も同時に行うなら、こんなかな?

Option Explicit

Public Sub Sample2()

  '元々のデータ列数(B列〜E列)
  Const clngColumns As Long = 4
  'グループの有る列(基準列B列からのC列の列Offset)
  Const clngGroup As Long = 1
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim vntGroup As Variant
  Dim vntItems As Variant
  Dim strProm As String

  '画面更新を停止
'  Application.ScreenUpdating = False
  
  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = ActiveSheet.Cells(1, "B")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row + 1
    If lngRows <= 0 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(, clngColumns).Resize(lngRows).Value = vntData
    'データをC列で整列
    DataSort .Resize(lngRows, clngColumns + 1), .Offset(, clngGroup)
    '復帰用Keyの再取得
    vntData = .Offset(, clngColumns).Resize(lngRows + 1).Value
    'C列データを配列に取得
    vntGroup = .Offset(, clngGroup).Resize(lngRows + 1).Value
    'B列データを配列に取得
    vntItems = .Resize(lngRows + 1).Value
  End With
  
  '注目値の位置を記録
  lngTop = 1
  '削除行数のカウント初期値
  lngCount = 0
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      '注目値の位置を記録
      lngTop = i
    Else
      '結果用変数に「・」を挟んで追加
      vntItems(lngTop, 1) = vntItems(lngTop, 1) & "・" & vntItems(i, 1)
      '削除行の復帰用KeyをEmptyに
      vntData(i, 1) = Empty
      '削除行数を更新
      lngCount = lngCount + 1
    End If
  Next i

  With rngList
    '結果を出力
    .Offset(, clngColumns - 1).Resize(lngRows).Value = vntItems
    '復帰用Keyの出力
    .Offset(, clngColumns).Resize(lngRows).Value = vntData
    '元データを復帰
    DataSort .Resize(lngRows, clngColumns + 1), .Offset(1, clngColumns)
    If lngCount > 0 Then
      '削除行を削除
      .Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
    End If
    '復帰用Key列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
   
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

【41595】Re:縦セル内の文字を合成したいのです。
お礼  くじら E-MAIL  - 06/8/15(火) 13:57 -

引用なし
パスワード
   へっぽこ様
 くじらです。大変丁寧な記述で感謝しております。
さて、このマクロは、このURLでダウンロードしたデータを加工するために作成しています。

http://www.ntt-east.co.jp/info-st/info_dsl/area.html
(住所2、3、備考は削除して検証)

早速ですが、検証させていただきます。
後はなんとかなりそうです。

ありがとうございました。m(_ _)m

【41596】Re:縦セル内の文字を合成したいのです。
お礼  くじら E-MAIL  - 06/8/15(火) 13:59 -

引用なし
パスワード
   Hirofumi様
 くじらです。大変丁寧な記述で感謝しております。
さて、このマクロは、このURLでダウンロードしたデータを加工するために作成しています。

http://www.ntt-east.co.jp/info-st/info_dsl/area.html
(住所2、3、備考は削除して検証)

早速ですが、検証させていただきます。
後はなんとかなりそうです。

ありがとうございました。m(_ _)m

7038 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free