Excel VBA質問箱 IV

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

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


6345 / 13646 ツリー ←次へ | 前へ→

【45777】複数行の項目を同一項目で、1行にまとめたい・・・ NOKO 07/1/14(日) 2:49 質問[未読]
【45781】Re:複数行の項目を同一項目で、1行にまと... Kein 07/1/14(日) 4:07 回答[未読]
【45783】Re:複数行の項目を同一項目で、1行にまと... Hirofumi 07/1/14(日) 8:41 回答[未読]
【45792】Re:複数行の項目を同一項目で、1行にまと... Hirofumi 07/1/14(日) 15:08 回答[未読]

【45777】複数行の項目を同一項目で、1行にまとめ...
質問  NOKO  - 07/1/14(日) 2:49 -

引用なし
パスワード
   はじめて質問させていただきます。先輩方のお知恵をお貸しください。

地域の子供のプロフィールが記載されている名簿を元に、1行ごと1世帯でまとめて兄弟を羅列させた表を作成したいです。

【エクセル名簿 1表】

  A        B      C
1 保護者名    住 所   園児名
2  相川 一郎  A町123-1  相川 太郎
3  井上 建二  B町55-21  井上 正
4  相川 一郎  A町123-1  相川 太郎
5  内田 浩二  C町1215    内田 良子
6  内田 浩二  C町1215   内田 花子
7  遠藤 司    A町166-9  遠藤 巧
8  相川 一郎  D町89-1   相川 登
9  相川 一郎  A町123-1  相川 優
10 遠藤 司   A町123-1  遠藤 真澄
(およそ2000行2000人分)

↓↓↓

【エクセル 2表】
    A      B       C       D       E       F
1 保護者名   住 所    園児名   園児名   園児名    園児数
2 相川 一郎 A町123-1  相川 太郎  相川 太郎 相川 優      3
3 相川 一郎 D町89-1   相川 登                    1
3 井上 建二 B町55-21  井上  正                    1
4 内田 浩二 C町1215   内田 良子   内田 花子           2
5 遠藤 司   A町166-9   遠藤 巧   遠藤 真澄           2


保護者名と住所を同じくする園児名を、同じ行に表示させたいのですが方法がわかりません…。
同姓同名の保護者名がある(住所は違います)ことが注意点で、できれば最右列にその世帯の園児数を表示させたいとも思っています。

知人数名に聞いたところ、無理でしょぅ〜と言われてしまい困っています…。
わかりにくい説明で申し訳ありませんが、ご質問、ご回答をお待ちしております!よろしくお願いします。

【45781】Re:複数行の項目を同一項目で、1行にま...
回答  Kein  - 07/1/14(日) 4:07 -

引用なし
パスワード
   仮に1表があるシートを Sheet1 として、Sheet2 に2表を作るとします。
以下のようなコードで出来ると思います。

Sub Mk_NewTable()
  Dim MyR As Range, C As Range
  Dim i As Integer, j As Integer, MxC As Integer
  Dim ChildCnt() As Integer
  Dim MyCld As Variant
 
  With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
  With Sheets("Sheet2")
   .Cells.ClearContents
   Sheets("Sheet1").Range("A1").CurrentRegion.Copy .Range("B1")
   .Range("B1").CurrentRegion.Sort Key1:=.Range("B1"), _
   Order1:=xlAscending, key2:=.Range("C1"), Order2:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
   .Range("A1").Value = "作業Data"
   .Range("B2", .Range("B65536").End(xlUp)).Offset(, -1) _
   .Formula = "=$B2&$C2"
   .Range("A1").CurrentRegion.Subtotal 1, xlCount, Array(3)
   Set MyR = .Range("B2", .Range("B65536").End(xlUp)) _
   .SpecialCells(2)
   For Each C In MyR.Areas
     C.Cells(1).Offset(, 254).Value = 1: j = C.Count
     ReDim Preserve ChildCnt(i): ChildCnt(i) = j: i = i + 1
     If j > 1 Then
      MyCld = WorksheetFunction.Transpose(C.Offset(, 2).Value)
      C.Cells(1).Offset(, 2).Resize(, j).Value = MyCld
     End If
   Next
   .Range("A1").CurrentRegion.RemoveSubtotal
   .Range("A2", .Range("A65536").End(xlUp)).Offset(, 255) _
   .SpecialCells(4).EntireRow.Delete xlShiftUp
   .Range("A:A").Delete xlShiftToLeft
   MxC = WorksheetFunction.Max(ChildCnt)
   .Range("C1").Resize(, MxC).Value = "園児名"
   .Range("A1").Offset(, MxC + 2).Value = "園児数"
   .Range("A2").Offset(, MxC + 2).Resize(UBound(ChildCnt) + 1) _
   .Value = WorksheetFunction.Transpose(ChildCnt)
   .Activate
  End With
  Erase ChildCnt: Set MyR = Nothing
  With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
  End With
End Sub

【45783】Re:複数行の項目を同一項目で、1行にま...
回答  Hirofumi  - 07/1/14(日) 8:41 -

引用なし
パスワード
   Sheet1にデータが有るとして、列見出しが有る物とします
データは、A列〜C列の3列とします
結果は、Sheet2に出力に出力される物とします
実行時にA列昇順のB列昇順で整列され、終了直前に元の行位置に再整列されます

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜C列)
  Const clngColumns As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim k As Long '★2重登録をスッキップ時に使用
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngMember() As Long
  Dim vntMember As Variant
  Dim lngMemberMax As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim vntGroup As Variant
  Dim strProm As String

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

  '出力Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 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(1, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データをA列昇順のB列昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1), Order1:=xlAscending, _
        Key2:=.Offset(1, 1), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
            
    'Key(A列〜B列)データを配列に取得
    vntGroup = .Offset(1).Resize(lngRows + 1, 2).Value
  End With
  
  '園児数をカウントする配列を確保
  ReDim lngMember(1 To lngRows, 1 To 1)
  '出力行位置の初期値
  lngWrite = 1
  '先頭値の位置を記録
  lngTop = 1
  '同一グループ(保護者+住所)データ行数のカウント初期値
  lngCount = 1
  For i = 2 To lngRows + 1
    '注目行と現在行の値が(保護者+住所)違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) _
        Or vntGroup(lngTop, 2) <> vntGroup(i, 2) Then
      '同一グループの園児名を配列に取得
      vntMember = rngList.Offset(lngTop, 2) _
                  .Resize(lngCount + 1).Value
      '園児数をカウント
      lngMember(lngWrite, 1) = lngCount
      '結果出力用配列を確保(保護者+住所+園児名1+園児名2・・)
      ReDim vntResult(1 To 2 + lngCount)
      '結果出力用配列に保護者、住所を転記
      vntResult(1) = vntGroup(lngTop, 1)
      vntResult(2) = vntGroup(lngTop, 2)
      '★サンプルデータでは、同一の保護者に同名の園児が
      '2人居る事に成ってますが?
      'データの2重登録をスッキップする場合、以下◎印を★印の様に
  '-----------------------------------------------------------------
      '結果出力用配列に園児を転記
      For j = 1 To lngCount '◎
        vntResult(2 + j) = vntMember(j, 1) '◎
      Next j '◎
      '園児数をカウント
      lngMember(lngWrite, 1) = lngCount '◎
      '園児数最大値を保存
      If lngMemberMax < lngCount Then '◎
        lngMemberMax = lngCount '◎
      End If '◎
  '-----------------------------------------------------------------
'      '結果出力用配列に園児を転記
'      k = 0 '★
'      For j = 1 To lngCount '★
'        If vntResult(2 + k) <> vntMember(j, 1) Then '★
'          k = k + 1 '★
'          vntResult(2 + k) = vntMember(j, 1) '★
'        End If '★
'      Next j '★
'      '園児数をカウント
'      lngMember(lngWrite, 1) = k '★
'      '園児数最大値を保存
'      If lngMemberMax < k Then '★
'        lngMemberMax = k '★
'      End If '★
  '-----------------------------------------------------------------
      '結果データを出力
      rngResult.Offset(lngWrite).Resize(, _
                2 + lngCount).Value = vntResult
      '出力行位置を更新
      lngWrite = lngWrite + 1
      '注目行の位置を記録
      lngTop = i
      '同一グループ(保護者+住所)データ行数のカウント初期値に
      lngCount = 1
    Else
      '同一グループ(保護者+住所)データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i
  With rngResult
    '園児数を出力
    .Offset(1, 2 + lngMemberMax) _
      .Resize(lngWrite - 1).Value = lngMember
    '結果シートに列見出しを出力
    rngList.Resize(, 2).Copy Destination:=rngResult
    ReDim vntResult(1 To lngMemberMax + 1)
    For i = 1 To lngMemberMax
      vntResult(i) = "園児名"
    Next i
    vntResult(lngMemberMax + 1) = "園児数"
    .Offset(, 2).Resize(, lngMemberMax + 1).Value = vntResult
  End With
    
  With rngList
    '元データを復帰
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    
    '復帰用Key列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
   
  strProm = "処理が完了しました"
   
Wayout:

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

【45792】Re:複数行の項目を同一項目で、1行にま...
回答  Hirofumi  - 07/1/14(日) 15:08 -

引用なし
パスワード
   あ!、行けね!

2重登録をスッキップする時は、最初の整列も変えなければ行けなかった!
★2重登録のスッキップを行う時は、以下も変更して下さい

    'データをA列昇順のB列昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1), Order1:=xlAscending, _
        Key2:=.Offset(1, 1), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke


    'データをA列昇順のB列昇順のC列昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1), Order1:=xlAscending, _
        Key2:=.Offset(1, 1), Order2:=xlAscending, _
        Key3:=.Offset(1, 2), Order3:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke

また、以下の部分が、重複の消し忘れなので削除して下さい

      '同一グループの園児名を配列に取得
      vntMember = rngList.Offset(lngTop, 2) _
                  .Resize(lngCount + 1).Value
'      '園児数をカウント '★下部でコードが重複して居るので削除
'      lngMember(lngWrite, 1) = lngCount '★下部でコードが重複して居るので削除
      '結果出力用配列を確保(保護者+住所+園児名1+園児名2・・)

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